diff --git a/.github/CONTRIBUTING.md b/.github/CONTRIBUTING.md deleted file mode 100644 index d32d9b7f1c..0000000000 --- a/.github/CONTRIBUTING.md +++ /dev/null @@ -1,43 +0,0 @@ -# Contributing to Elm - -Thanks helping with the development of Elm! This document describes the basic -standards for opening pull requests and making the review process as smooth as -possible. - -## Licensing - -You need to sign the [contributor agreement](ContributorAgreement.pdf) -and send it to before opening your pull request. - -## Style Guide - - * Haskell — conform to [these guidelines][haskell] - * JavaScript — use [Google's JS style guide][js] - -[haskell]: https://gist.github.com/evancz/0a1f3717c92fe71702be -[js]: https://google.github.io/styleguide/javascriptguide.xml - -## Branches - - * [The master branch][master] is the home of the next release of the compiler - so new features and improvements get merged there. Most pull requests - should target this branch! - - * [The stable branch][stable] is for tagging releases and critical bug fixes. - This branch is handy for folks who want to build the most recent public - release from source. - -[master]: http://github.com/elm-lang/elm/tree/master -[stable]: http://github.com/elm-lang/elm/tree/stable - -If you are working on a fairly large feature, we will probably want to merge it -in as its own branch and do some testing before bringing it into the master -branch. This way we can keep releases of the master branch independent of new -features. - -Note that the master branch of the compiler should always be in sync with the -master branch of the [website][], and the stable branch of the compiler should -always be in sync with the stable branch of the [website][]. Make sure that -your changes maintain this compatibility. - -[website]: https://github.com/elm-lang/elm-lang.org diff --git a/.github/ISSUE_TEMPLATE.md b/.github/ISSUE_TEMPLATE.md deleted file mode 100644 index 8ab67b3d89..0000000000 --- a/.github/ISSUE_TEMPLATE.md +++ /dev/null @@ -1,18 +0,0 @@ - -**Quick Summary:** ??? - - -## SSCCE - -```elm - -``` - -- **Elm:** ??? -- **Browser:** ??? -- **Operating System:** ??? - - -## Additional Details - -??? \ No newline at end of file diff --git a/.github/ISSUE_TEMPLATE/bug_report.md b/.github/ISSUE_TEMPLATE/bug_report.md new file mode 100644 index 0000000000..e2ba7ec2df --- /dev/null +++ b/.github/ISSUE_TEMPLATE/bug_report.md @@ -0,0 +1,39 @@ +--- +name: Bug report +about: Create a report to help us improve +title: "[BUG]" +labels: bug +assignees: '' + +--- + +**Describe the bug** +A clear and concise description of what the bug is. + +**To Reproduce** +Steps to reproduce the issue (please include code snippets, input files, or commands if possible): +1. Go to '...' +2. Click on '....' +3. Scroll down to '....' +4. See error + +**Expected behavior** +A clear and concise description of what you expected to happen. + +**Actual behavior / error output** +Include any error messages or unexpected outputs you received. + +**Example Code or Project** +If applicable, please share the relevant snippet of Guida code or a minimal reproduction. + +**Environment** +- OS: [e.g. Ubuntu 22.04, macOS Ventura] +- Node.js version: [e.g. 23.10.0] +- Guida version: [e.g. 1.0.0-alpha] +- Browser (if compiling in-browser): [e.g. Firefox 128] + +**Additional context** +Add any other context about the problem here. + +- Does this relate to an existing Elm issue? +- Did this behavior appear after a recent change? diff --git a/.github/ISSUE_TEMPLATE/feature_request.md b/.github/ISSUE_TEMPLATE/feature_request.md new file mode 100644 index 0000000000..d3d7c726e4 --- /dev/null +++ b/.github/ISSUE_TEMPLATE/feature_request.md @@ -0,0 +1,23 @@ +--- +name: Feature request +about: Suggest an idea for this project +title: "[FEATURE]" +labels: enhancement +assignees: '' + +--- + +**Is your feature request related to a problem? Please describe.** +A clear and concise description of what the problem is. Ex. I'm always frustrated when [...] + +**Describe the solution you'd like** +A clear and concise description of what you want to happen. + +**Describe alternatives you've considered** +A clear and concise description of any alternative solutions or features you've considered. + +**Related Elm Features** +If this feature exists in Elm (e.g., compiler, elm-format, elm-test, elm-json), or was previously discussed, please reference it. + +**Additional context** +Add any other context or screenshots about the feature request here. diff --git a/.github/PULL_REQUEST_TEMPLATE.md b/.github/PULL_REQUEST_TEMPLATE.md deleted file mode 100644 index de5ff46b18..0000000000 --- a/.github/PULL_REQUEST_TEMPLATE.md +++ /dev/null @@ -1,18 +0,0 @@ - -**Quick Summary:** ??? - - -## SSCCE - -```elm - -``` - -- **Elm:** ??? -- **Browser:** ??? -- **Operating System:** ??? - - -## Additional Details - -??? diff --git a/.github/pull_request_template.md b/.github/pull_request_template.md new file mode 100644 index 0000000000..b332637cbc --- /dev/null +++ b/.github/pull_request_template.md @@ -0,0 +1,42 @@ +# Pull Request + +Thank you for contributing to Guida! +Please complete the checklist and provide context below. + +--- + +## 📋 Summary + +Briefly describe the goal of this pull request and what problem it solves. + +--- + +## ✅ Checklist + +- [ ] The code compiles and all tests pass (`npm test`) +- [ ] The change has been tested in: + - [ ] CLI + - [ ] Browser + - [ ] Node (API) +- [ ] I’ve added or updated tests, if applicable +- [ ] I’ve updated relevant documentation or comments +- [ ] My changes follow the project's coding style + +--- + +## 🔍 Related Issues + +List any existing issues or discussions this PR is related to (use `#123` references if applicable). + +--- + +## 💬 Notes for Reviewers + +Anything specific reviewers should be aware of (e.g., implementation notes, edge cases, questions for feedback)? + +--- + +## 📎 Additional Context + +If your change relates to a past decision in Elm (e.g., compiler, elm-format, elm-test), please provide a link or brief mention. + diff --git a/.github/workflows/main.yml b/.github/workflows/main.yml new file mode 100644 index 0000000000..af0aed6b24 --- /dev/null +++ b/.github/workflows/main.yml @@ -0,0 +1,32 @@ +# This workflow will do a clean installation of node dependencies, cache/restore them, build the source code and run tests for the configured nvm version of node +# For more information see: https://docs.github.com/en/actions/automating-builds-and-tests/building-and-testing-nodejs + +name: CI + +on: + push: + branches: ["**"] + pull_request: + branches: ["**"] + +jobs: + build: + runs-on: ubuntu-latest + timeout-minutes: 15 + + steps: + - uses: actions/checkout@v4 + - uses: actions/setup-node@v4 + with: + node-version-file: ".nvmrc" + cache: "npm" + - run: npm ci + - run: npm run build:bin + - run: npm run build:browser + - run: npm run test:eslint + - run: npm run test:elm-format-validate + - run: npm run test:jest + - run: npm run test:elm + - run: npm run test:elm-review + - name: self-hosted environment + run: ./bin/index.js make --optimize src/Terminal/Main.elm diff --git a/.gitignore b/.gitignore index e17cc13acd..29b217f410 100644 --- a/.gitignore +++ b/.gitignore @@ -1,7 +1,28 @@ +node_modules elm-stuff -dist -cabal-dev -.cabal-sandbox/ -cabal.sandbox.config .DS_Store -*~ +.idea + +# Guida +guida-stuff + +# Main +lib/guida.node.js +lib/guida.node.min.js + +# Browser +lib/guida.browser.js +lib/guida.browser.min.js + +# Command line +bin/guida.js +bin/guida.min.js + +# Try +try/public/app.js + +# Assets +assets/some-application/index.html + +# Examples +examples/index.html diff --git a/.npmignore b/.npmignore new file mode 100644 index 0000000000..9c8a2eae95 --- /dev/null +++ b/.npmignore @@ -0,0 +1,15 @@ +.github +bin/guida.js +elm-stuff +examples +lib/guida.node.js +lib/guida.browser.js +guida-stuff +review +scripts +src +tests +try +.nvmrc +elm.json +eslint.config.mjs \ No newline at end of file diff --git a/.nvmrc b/.nvmrc new file mode 100644 index 0000000000..9292feee03 --- /dev/null +++ b/.nvmrc @@ -0,0 +1 @@ +v23.10.0 \ No newline at end of file diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 index 0000000000..a5d3a21028 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,56 @@ +# Changelog + +All notable changes to this project will be documented in this file. + +The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.1.0/), +and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0.html). + +## [Unreleased] + +### Added + +- WIP: Allow running the `make` command in the browser ([#94](https://github.com/guida-lang/compiler/issues/94)) +- Initial REPL tests for basic arithmetic evaluation +- New `test` command ([#98](https://github.com/guida-lang/compiler/issues/98)) +- Add `elm-explorations/test` dependency as part of `init` ([#65](https://github.com/guida-lang/compiler/issues/65)) +- Extend record referred by another record’s field ([#79](https://github.com/guida-lang/compiler/issues/79)) +- Add a `CONTRIBUTING.md` file ([#103](https://github.com/guida-lang/compiler/issues/103)) +- `guida format` command ([#100](https://github.com/guida-lang/compiler/issues/100)) +- Numeric separators ([#109](https://github.com/guida-lang/compiler/issues/109)) +- Binary literals support ([#2248](https://github.com/elm/compiler/issues/2248)) +- Bool type support in WebGL shader interface ([#2120](https://github.com/elm/compiler/issues/2120)). + +### Fixed + +- Correct reporting of multiple errors ([#99](https://github.com/guida-lang/compiler/issues/99)) +- Replaced infinite looping `Crash.crash` with log and exit ([#120](https://github.com/guida-lang/compiler/issues/120)) + +### Changed + +- Refactored project structure to support both Node and Browser environments +- Refactoring of `Task` aliases for a more unified approach across the codebase ([#108](https://github.com/guida-lang/compiler/issues/108)) + +--- + +## [1.0.0-alpha] – 2025-03-28 + +### Added + +- Initial stable release. +- Allow tuples with 3+ elements ([#75](https://github.com/guida-lang/compiler/issues/75). +- Support for `GUIDA_REGISTRY` environment variable. +- New `--yes` flag for `init` command ([#80](https://github.com/guida-lang/compiler/issues/80)). +* Support modifying records via qualified names ([#78](https://github.com/guida-lang/compiler/issues/78)). +- New `--package` flag for `init` command ([#43](https://github.com/guida-lang/compiler/issues/43)). +- New `--test` flag for `install` command ([#64](https://github.com/guida-lang/compiler/issues/64)). +- `uninstall` command ([#60](https://github.com/guida-lang/compiler/issues/60). +- Source maps support ([#63](https://github.com/guida-lang/compiler/issues/63). +- Guida-specific syntax for underscore wildcard variables ([#59](https://github.com/guida-lang/compiler/issues/59). +- Format command (`guida format`) ([#58](https://github.com/guida-lang/compiler/issues/58), fixes [#42](https://github.com/guida-lang/compiler/issues/42)). +- Self-hosted environment ([#9](https://github.com/guida-lang/compiler/issues/9) +- `--optimize` flag for `build` command ([#36](https://github.com/guida-lang/compiler/issues/36)). + +### Changed + +- Bumped version to `1.0.0`. +- Reduced size of `guida-stuff` from ~97.7 MB to ~27.5 MB. \ No newline at end of file diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md new file mode 100644 index 0000000000..00a21eff3a --- /dev/null +++ b/CONTRIBUTING.md @@ -0,0 +1,131 @@ +# Contributing to Guida + +:+1::tada: First off, thank you for your interest in contributing to Guida! :tada::+1: + +This document outlines guidelines and best practices for contributing code, ideas, or feedback to the project. + +--- + +## 📋 Table of Contents + +- [Getting Started](#getting-started) +- [Ways to Contribute](#ways-to-contribute) +- [Expectations](#expectations) +- [Development Setup](#development-setup) +- [Testing Your Changes](#testing-your-changes) +- [Submitting a Pull Request](#submitting-a-pull-request) +- [Style Guide](#style-guide) +- [Reporting Issues](#reporting-issues) +- [Questions?](#questions) + +--- + +## Getting Started + +Guida is a functional programming language that builds upon the solid foundation of Elm, offering +backward compatibility with all existing Elm 0.19.1 projects. + +Find out more about our [Vision](README.md#vision) on the project [README](README.md). + +We welcome contributions of all kinds, code, documentation, bug reports, feedback, and ideas! + +If you're unsure about where to start or how to approach an issue, feel free to open a [discussion](https://github.com/guida-lang/compiler/discussions) +or join our [Guida Discord server](https://discord.gg/Ur33engz) to connect with other contributors and users. +We’re happy to help point you in the right direction! + +--- + +## Ways to Contribute + +- File a bug or feature request [here](https://github.com/guida-lang/compiler/issues) +- Help triage existing issues +- Submit improvements to the [compiler](https://github.com/guida-lang/compiler), [registry](https://github.com/guida-lang/package-registry), or [tooling](https://github.com/guida-lang) +- Improve documentation or examples +- Try out Guida and give us feedback +- Look for [good first issues](https://github.com/guida-lang/compiler/issues?q=is%3Aissue+is%3Aopen+label%3A%22good+first+issue%22) if you're just getting started +- Port known issues or improvements from the Elm ecosystem + + Guida builds on projects like [elm/compiler](https://github.com/elm/compiler), [elm-format](https://github.com/avh4/elm-format), [elm-test](https://github.com/elm-explorations/test), and [elm-json](https://github.com/zwilias/elm-json). If you've encountered issues or ideas in those tools that feel worth bringing into Guida, feel free to reference them in a new issue or PR + +--- + +## Expectations + +- We aim to respond to contributions within a few days. +- All changes should align with the project's vision: stability, compatibility with Elm, and community evolution. +- PRs should be focused and include a clear description. +- Don’t worry if your PR needs changes — we’ll help you get it over the finish line! + +--- + +## Development Setup + +For detailed instructions on setting up your environment for contributing to Guida, see the [Development](README.md#development) section of the README. + +## Testing Your Changes + +We aim for stability and consistency. If you’re adding features or fixing bugs, please: + +- Write tests if applicable. +- Consider all 3 outputs of the project: bin (command line), browser and node (API). +- Make sure to test all three output targets of the project: + - CLI (bin) — the command-line interface + - Browser — compiled for browser usage + - Node — used as a Node.js API +- Make sure existing tests pass: see the [Run tests](README.md#run-tests) section of the README. + +--- + +## Submitting a Pull Request + +1. Fork the repo and create a new branch: + ```sh + git checkout -b my-feature + ``` + +2. Make your changes. +3. Test locally. +4. Push and open a Pull Request (PR) to the `master` branch. + +Please describe: +- What the change does +- Why it’s needed +- Any related issues or discussion + +--- + +## Style Guide + +- Follow the existing code style +- Keep Elm code idiomatic and readable +- Use descriptive names and add comments where helpful + +For formatting Elm: + +```sh +npm run elm-format +``` + +--- + +## Reporting Issues + +If you encounter a bug or unexpected behavior: +- Search [existing issues](https://github.com/guida-lang/compiler/issues) +- If not found, open a new one with: + - Steps to reproduce + - Expected and actual behavior + - Environment details + +Some issues might relate to other repositories under the [guida-lang](https://github.com/guida-lang) (such as the package registry). +If you're unsure where the issue belongs, feel free to post anyway — we’ll help direct it to the right place. + +--- + +## Questions? + +Join the [Guida Discord server](https://discord.gg/Ur33engz) to connect with other contributors and users, ask questions, and share ideas. + +Please note that responses may come with a bit of delay, as availability can be limited during the day. + +Thank you again for helping improve Guida! \ No newline at end of file diff --git a/ContributorAgreement.pdf b/ContributorAgreement.pdf deleted file mode 100644 index 788773a052..0000000000 Binary files a/ContributorAgreement.pdf and /dev/null differ diff --git a/LICENSE b/LICENSE index 5343b32e1e..2f168fb8fc 100644 --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,5 @@ -Copyright 2012-present Evan Czaplicki +Original work Copyright 2012-2024 Evan Czaplicki +Modified work Copyright 2024-present Décio Ferreira Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: diff --git a/README.md b/README.md index 54f01c7489..e6d231f8bd 100644 --- a/README.md +++ b/README.md @@ -1,22 +1,186 @@ -# Elm +# Guida programming language -A delightful language for reliable webapps. +Guida is a functional programming language that builds upon the solid foundation of Elm, offering +backward compatibility with all existing Elm 0.19.1 projects. -Check out the [Home Page](http://elm-lang.org/), [Try Online](http://elm-lang.org/try), or [The Official Guide](http://guide.elm-lang.org/) +Join the [Guida Discord server](https://discord.gg/Ur33engz) to connect with the community, ask +questions, and share ideas. +# Vision -
+Guida builds on the foundations of Elm, aiming to advance the future of functional programming. +By translating Elm's compiler from Haskell to a self-hosted environment, Guida helps developers to +build reliable, maintainable, and performant applications without leaving the language they love. -## Install +**Continuity and Confidence (Version 0.x):** +Guida starts by ensuring full backward compatibility with Elm v0.19.1, allowing developers to migrate +effortlessly and explore Guida with complete confidence. -✨ [Install](https://guide.elm-lang.org/install/elm.html) ✨ +This commitment to continuity means that this version will faithfully replicate not only the +features and behaviors of Elm v0.19.1, but also any existing bugs and quirks. +By doing so, we provide a stable and predictable environment for developers, ensuring that their +existing Elm projects work exactly as expected when migrated to Guida. -For multiple versions, previous versions, and uninstallation, see the instructions [here](https://github.com/elm/compiler/blob/master/installers/README.md). +**Evolution and Innovation (Version 1.x and Beyond):** +As Guida evolves, we will introduce new features and improvements. +This phase will foster a unified ecosystem that adapts to the needs of its users. -
+**Core Principles:** -## Help +- **Backward Compatibility:** Respect for existing Elm projects, ensuring a frictionless migration. +- **Accessibility:** Lowering barriers for developers by implementing Guida’s core in its own syntax. -If you are stuck, ask around on [the Elm slack channel][slack]. Folks are friendly and happy to help with questions! +Our ultimate goal is to create a language that inherits the best aspects of Elm while adapting and +growing to meet the needs of its users. -[slack]: http://elmlang.herokuapp.com/ +# Install + +To install Guida as an npm package, run the following command: + +``` +npm install -g guida +``` + +You should now be able to run `guida --version`. + +# Development + +Start by installing [Node Version Manager](https://github.com/nvm-sh/nvm). + +Switch to the correct node version number by running: + +``` +nvm use +``` + +Install the dependencies: + +``` +npm install +``` + +Generate guida: + +``` +npm run build +``` + +Link the project to run `guida` command: + +``` +npm link +``` + +You should now be able to run `guida`: + +``` +guida --help +``` + +To compare the performance of guida with elm, you can run `./scripts/performance-comparison.sh`. + +## Watch mode + +You can run the following command to `build:bin` when anything is added, changed or deleted within the `src` directory: + +``` +npm run watch +``` + +# Examples + +To run an example `cd` into the `examples` folder, and run the `guida make` command: + +``` +cd examples +guida make --debug src/Hello.elm +``` + +You can then `open index.html`. + +# Try + +Find an example of how to use the browser version of the compiler on the [`try` folder](try/README.md). + +## Clear cache + +To clear all cache and re-generate `./bin/guida.js` run the following: + +``` +rm -rf ~/.guida guida-stuff; npm run build +``` + +# Run tests + +Run all tests: + +``` +npm test +``` + +Run `jest` tests: + +``` +npm test:jest +``` + +Run `elm-test` tests: + +``` +npm run test:elm +``` + +Run `elm-review` tests: + +``` +npm run test:elm-review +``` + +Run `elm-format` validation: + +``` +npm run test:elm-format-validate +``` + +# Format elm source code + +``` +npm run elm-format +``` + +# Publish new npm package version + +Before publishing a new npm package version, make sure you are on the correct +branch, ie. in case of wanting to publish a 0.x version, you should have the +`v0.x` branch checked out. + +To publish a new version, we should then run the following commands: + +``` +npm version +npm publish +git push origin +git push origin tag v +``` + +As an example, these should have been the commands ran for publishing `v0.2.0-alpha` + +``` +npm version 0.2.0-alpha +npm publish +git push origin v0.x +git push origin tag v0.2.0-alpha +``` + +The `` value relates to the `version` field value found on `package.json`. + +# References + +- Initial transpilation from Haskell to Elm done based on [Elm compiler v0.19.1](https://github.com/elm/compiler/releases/tag/0.19.1) + (more specifically [commit c9aefb6](https://github.com/elm/compiler/commit/c9aefb6230f5e0bda03205ab0499f6e4af924495)) +- Terminal logic implementation based on https://github.com/albertdahlin/elm-posix + +# Resources + +- [Hoogle](https://hoogle.haskell.org/) +- [Online Haskell Compiler](https://www.tutorialspoint.com/compile_haskell_online.php) diff --git a/worker/elm.json b/assets/some-application/elm.json similarity index 62% rename from worker/elm.json rename to assets/some-application/elm.json index 469d9b7bd1..ce2a08dc77 100644 --- a/worker/elm.json +++ b/assets/some-application/elm.json @@ -6,17 +6,15 @@ "elm-version": "0.19.1", "dependencies": { "direct": { - "elm/browser": "1.0.1", - "elm/core": "1.0.2", - "elm/html": "1.0.0", - "elm/json": "1.1.3", - "elm/project-metadata-utils": "1.0.0" + "elm/browser": "1.0.2", + "elm/core": "1.0.5", + "elm/html": "1.0.0" }, "indirect": { - "elm/parser": "1.1.0", + "elm/json": "1.1.3", "elm/time": "1.0.0", "elm/url": "1.0.0", - "elm/virtual-dom": "1.0.2" + "elm/virtual-dom": "1.0.3" } }, "test-dependencies": { diff --git a/assets/some-application/src/ElmTupleN.elm b/assets/some-application/src/ElmTupleN.elm new file mode 100644 index 0000000000..87d880ceed --- /dev/null +++ b/assets/some-application/src/ElmTupleN.elm @@ -0,0 +1,32 @@ +module ElmTupleN exposing + ( tuple2 + , tuple3 + , tuple4 + , tuple5 + , tuple6 + ) + + +tuple2 : ( Int, Int ) +tuple2 = + ( 1, 2 ) + + +tuple3 : ( Int, Int, Int ) +tuple3 = + ( 1, 2, 3 ) + + +tuple4 : ( Int, Int, Int, Int ) +tuple4 = + ( 1, 2, 3, 4 ) + + +tuple5 : ( Int, Int, Int, Int, Int ) +tuple5 = + ( 1, 2, 3, 4, 5 ) + + +tuple6 : ( Int, Int, Int, Int, Int, Int ) +tuple6 = + ( 1, 2, 3, 4, 5, 6 ) diff --git a/assets/some-application/src/GuidaTupleN.guida b/assets/some-application/src/GuidaTupleN.guida new file mode 100644 index 0000000000..a2ca035430 --- /dev/null +++ b/assets/some-application/src/GuidaTupleN.guida @@ -0,0 +1,32 @@ +module GuidaTupleN exposing + ( tuple2 + , tuple3 + , tuple4 + , tuple5 + , tuple6 + ) + + +tuple2 : ( Int, Int ) +tuple2 = + ( 1, 2 ) + + +tuple3 : ( Int, Int, Int ) +tuple3 = + ( 1, 2, 3 ) + + +tuple4 : ( Int, Int, Int, Int ) +tuple4 = + ( 1, 2, 3, 4 ) + + +tuple5 : ( Int, Int, Int, Int, Int ) +tuple5 = + ( 1, 2, 3, 4, 5 ) + + +tuple6 : ( Int, Int, Int, Int, Int, Int ) +tuple6 = + ( 1, 2, 3, 4, 5, 6 ) diff --git a/assets/some-application/src/Invalid.elm b/assets/some-application/src/Invalid.elm new file mode 100644 index 0000000000..f9a5bf7f33 --- /dev/null +++ b/assets/some-application/src/Invalid.elm @@ -0,0 +1 @@ +module Invalid exposing (..) diff --git a/assets/some-application/src/MaybeMap.elm b/assets/some-application/src/MaybeMap.elm new file mode 100644 index 0000000000..57424a9f26 --- /dev/null +++ b/assets/some-application/src/MaybeMap.elm @@ -0,0 +1,71 @@ +module MaybeMap exposing (main) + +import Html exposing (Html) + + +andMap : Maybe a -> Maybe (a -> b) -> Maybe b +andMap = + Maybe.map2 (|>) + + +type alias X = + { x1 : Int + , x2 : Int + , x3 : Int + , x4 : Int + , x5 : Int + , x6 : Int + , x7 : Int + , x8 : Int + , x9 : Int + , x10 : Int + , x11 : Int + , x12 : Int + , x13 : Int + , x14 : Int + , x15 : Int + , x16 : Int + , x17 : Int + , x18 : Int + , x19 : Int + , x20 : Int + , x21 : Int + , x22 : Int + , x23 : Int + , x24 : Int + } + + +main : Html msg +main = + let + foo a = + Just X + |> andMap a + |> andMap a + |> andMap a + |> andMap a + |> andMap a + |> andMap a + |> andMap a + |> andMap a + |> andMap a + |> andMap a + |> andMap a + |> andMap a + |> andMap a + |> andMap a + |> andMap a + |> andMap a + |> andMap a + |> andMap a + |> andMap a + |> andMap a + |> andMap a + |> andMap a + |> andMap a + |> andMap a + in + foo (Just 1) + |> Debug.toString + |> Html.text diff --git a/assets/some-application/src/Rank2TypecheckBug.elm b/assets/some-application/src/Rank2TypecheckBug.elm new file mode 100644 index 0000000000..e5235fc346 --- /dev/null +++ b/assets/some-application/src/Rank2TypecheckBug.elm @@ -0,0 +1,10 @@ +module Rank2TypecheckBug exposing (..) + + +f x = + let + g : (a -> ()) -> () + g h = + h x + in + x diff --git a/assets/some-package/elm.json b/assets/some-package/elm.json new file mode 100644 index 0000000000..40a8911b9a --- /dev/null +++ b/assets/some-package/elm.json @@ -0,0 +1,15 @@ +{ + "type": "package", + "name": "author/project", + "summary": "Update this with a brief description before publishing.", + "license": "BSD-3-Clause", + "version": "1.0.0", + "exposed-modules": [ + "Main" + ], + "elm-version": "0.19.1 <= v < 0.20.0", + "dependencies": { + "elm/core": "1.0.5 <= v < 2.0.0" + }, + "test-dependencies": {} +} \ No newline at end of file diff --git a/assets/some-package/src/Main.elm b/assets/some-package/src/Main.elm new file mode 100644 index 0000000000..b0b0dc620e --- /dev/null +++ b/assets/some-package/src/Main.elm @@ -0,0 +1,20 @@ +module Main exposing (add1) + +{-| This is a test package for testing the Elm compiler. + + +# Example + +@docs add1 + +-} + + +{-| Add 1 to the given number. + + add1 2 == 3 + +-} +add1 : Int -> Int +add1 x = + x + 1 diff --git a/bin/index.js b/bin/index.js new file mode 100755 index 0000000000..c1f51cbddd --- /dev/null +++ b/bin/index.js @@ -0,0 +1,488 @@ +#!/usr/bin/env node + +const fs = require("node:fs"); +const child_process = require("node:child_process"); +const readline = require("node:readline"); +const os = require("node:os"); +const http = require("node:http"); +const https = require("node:https"); +const resolve = require("node:path").resolve; +const zlib = require("node:zlib"); +const crypto = require("node:crypto"); +const AdmZip = require("adm-zip"); +const which = require("which"); +const tmp = require("tmp"); +const FormData = require("form-data"); +const { newServer } = require("mock-xmlhttprequest"); + +const rl = readline.createInterface({ + input: process.stdin, + output: process.stdout, +}); + +let nextCounter = 0, mVarsNextCounter = 0; +let stateT = { imports: {}, types: {}, decls: {} }; +const mVars = {}; +const lockedFiles = {}; +const processes = {}; + +const download = function (method, url) { + const req = https.request(url, { method }, (res) => { + if (res.statusCode >= 200 && res.statusCode < 300) { + let chunks = []; + + res.on("data", (chunk) => { + chunks.push(chunk); + }); + + res.on("end", () => { + const buffer = Buffer.concat(chunks); + const zip = new AdmZip(buffer); + + const sha = crypto.createHash("sha1").update(buffer).digest("hex"); + + const archive = zip.getEntries().map(function (entry) { + return { + eRelativePath: entry.entryName, + eData: zip.readAsText(entry), + }; + }); + + this.send({ sha, archive }); + }); + } else if (res.headers.location) { + download.apply(this, [method, res.headers.location]); + } + }); + + req.on("error", (e) => { + console.error(e); + }); + + req.end(); +}; + +const server = newServer(); + +server.post("getLine", (request) => { + rl.on("line", (value) => { + request.respond(200, null, value); + }); +}); + +server.post("hPutStr", (request) => { + const fd = parseInt(request.requestHeaders.getHeader("fd")); + + fs.write(fd, request.body, (err) => { + if (err) throw err; + request.respond(200); + }); +}); + +server.post("writeString", (request) => { + const path = request.requestHeaders.getHeader("path"); + + fs.writeFile(path, request.body, (err) => { + if (err) throw err; + request.respond(200); + }); +}); + +server.post("read", (request) => { + fs.readFile(request.body, (err, data) => { + if (err) throw err; + request.respond(200, null, data.toString()); + }); +}); + +server.post("readStdin", (request) => { + fs.readFile(0, (err, data) => { + if (err) throw err; + request.respond(200, null, data.toString()); + }); +}); + +server.post("getArchive", (request) => { + download.apply({ + send: ({ sha, archive }) => { + request.respond(200, null, JSON.stringify({ sha, archive })); + } + }, ["GET", request.body]); +}); + +server.post("httpUpload", (request) => { + const { urlStr, headers, parts } = JSON.parse(request.body); + const url = new URL(urlStr); + const client = url.protocol == "https:" ? https : http; + + const form = new FormData(); + + parts.forEach((part) => { + switch (part.type) { + case "FilePart": + form.append(part.name, fs.createReadStream(part.filePath)); + break; + + case "JsonPart": + form.append(part.name, JSON.stringify(part.value), { + contentType: "application/json", + filepath: part.filePath, + }); + break; + + case "StringPart": + form.append(part.name, part.string); + break; + } + }); + + const req = client.request(url, { + method: "POST", + headers: { ...headers, ...form.getHeaders() }, + }); + + form.pipe(req); + + req.on("response", (res) => { + res.on("end", () => { + request.respond(200); + }); + }); + + req.on("error", (err) => { + throw err; + }); +}); + +server.post("withFile", (request) => { + const mode = request.requestHeaders.getHeader("mode"); + + fs.open(request.body, mode, (err, fd) => { + if (err) throw err; + request.respond(200, null, fd); + }); +}); + +server.post("hFileSize", (request) => { + fs.fstat(request.body, (err, stats) => { + if (err) throw err; + request.respond(200, null, stats.size); + }); +}); + +server.post("withCreateProcess", (request) => { + let createProcess = JSON.parse(request.body); + + tmp.file((err, path, fd) => { + if (err) throw err; + + nextCounter += 1; + + fs.createReadStream(path) + .on("data", (chunk) => { + processes[nextCounter].stdin.write(chunk); + }) + .on("close", () => { + processes[nextCounter].stdin.end(); + }); + + processes[nextCounter] = child_process.spawn( + createProcess.cmdspec.cmd, + createProcess.cmdspec.args, + { + stdio: [ + createProcess.stdin, + createProcess.stdout, + createProcess.stderr, + ], + } + ); + + request.respond(200, null, JSON.stringify({ stdinHandle: fd, ph: nextCounter })); + }); +}); + +server.post("hClose", (request) => { + const fd = parseInt(request.body); + fs.close(fd); + request.respond(200); +}); + +server.post("waitForProcess", (request) => { + const ph = parseInt(request.body); + processes[ph].on("exit", (code) => { + request.respond(200, null, code); + }); +}); + +server.post("exitWith", (request) => { + rl.close(); + process.exit(request.body); +}); + +server.post("dirFindExecutable", (request) => { + const path = which.sync(request.body, { nothrow: true }) ?? null; + request.respond(200, null, JSON.stringify(path)); +}); + +server.post("replGetInputLine", (request) => { + rl.question(request.body, (value) => { + request.respond(200, null, JSON.stringify(value)); + }); +}); + +server.post("dirDoesFileExist", (request) => { + fs.stat(request.body, (err, stats) => { + request.respond(200, null, !err && stats.isFile()); + }); +}); + +server.post("dirCreateDirectoryIfMissing", (request) => { + const { createParents, filename } = JSON.parse(request.body); + fs.mkdir(filename, { recursive: createParents }, (_err) => { + request.respond(200); + }); +}); + +server.post("lockFile", (request) => { + const path = request.body; + + if (lockedFiles[path]) { + lockedFiles[path].subscribers.push(request); + } else { + lockedFiles[path] = { subscribers: [] }; + request.respond(200); + } +}); + +server.post("unlockFile", (request) => { + const path = request.body; + + if (lockedFiles[path]) { + const subscriber = lockedFiles[path].subscribers.shift(); + + if (subscriber) { + subscriber.respond(200); + } else { + delete lockedFiles[path]; + } + + request.respond(200); + } else { + console.error(`Could not find locked file "${path}"!`); + rl.close(); + process.exit(255); + } +}); + +server.post("dirGetModificationTime", (request) => { + fs.stat(request.body, (err, stats) => { + if (err) throw err; + request.respond(200, null, parseInt(stats.mtimeMs, 10)); + }); +}); + +server.post("dirDoesDirectoryExist", (request) => { + fs.stat(request.body, (err, stats) => { + request.respond(200, null, !err && stats.isDirectory()); + }); +}); + +server.post("dirCanonicalizePath", (request) => { + request.respond(200, null, resolve(request.body)); +}); + +server.post("dirListDirectory", (request) => { + fs.readdir(request.body, { recursive: false }, (err, files) => { + if (err) throw err; + request.respond(200, null, JSON.stringify(files)); + }); +}); + +server.post("binaryDecodeFileOrFail", (request) => { + fs.readFile(request.body, (err, data) => { + if (err) throw err; + request.respond(200, null, data.buffer); + }); +}); + +server.post("write", (request) => { + const path = request.requestHeaders.getHeader("path"); + + fs.writeFile(path, request.body, (err) => { + if (err) throw err; + request.respond(200); + }); +}); + +server.post("dirRemoveFile", (request) => { + fs.unlink(request.body, (err) => { + if (err) throw err; + request.respond(200); + }); +}); + +server.post("dirRemoveDirectoryRecursive", (request) => { + fs.rm(request.body, { recursive: true, force: true }, (err) => { + if (err) throw err; + request.respond(200); + }); +}); + +server.post("dirWithCurrentDirectory", (request) => { + try { + process.chdir(request.body); + request.respond(200); + } catch (err) { + console.error(`chdir: ${err}`); + } +}); + +server.post("envGetArgs", (request) => { + request.respond(200, null, JSON.stringify(process.argv.slice(2))); +}); + +server.post("dirGetCurrentDirectory", (request) => { + request.respond(200, null, process.cwd()); +}); + +server.post("envLookupEnv", (request) => { + const envVar = process.env[request.body] ?? null; + request.respond(200, null, JSON.stringify(envVar)); +}); + +server.post("dirGetAppUserDataDirectory", (request) => { + request.respond(200, null, `${os.homedir()}/.${request.body}`); +}); + +server.post("putStateT", (request) => { + stateT = request.body; + request.respond(200); +}); + +server.post("getStateT", (request) => { + request.respond(200, null, stateT.buffer); +}); + +// MVARS +server.post("newEmptyMVar", (request) => { + mVarsNextCounter += 1; + mVars[mVarsNextCounter] = { subscribers: [], value: undefined }; + request.respond(200, null, mVarsNextCounter); +}); + +server.post("readMVar", (request) => { + const id = request.body; + if (typeof mVars[id].value === "undefined") { + mVars[id].subscribers.push({ action: "read", request }); + } else { + request.respond(200, null, mVars[id].value.buffer); + } +}); + +server.post("takeMVar", (request) => { + const id = request.body; + if (typeof mVars[id].value === "undefined") { + mVars[id].subscribers.push({ action: "take", request }); + } else { + const value = mVars[id].value; + mVars[id].value = undefined; + + if ( + mVars[id].subscribers.length > 0 && + mVars[id].subscribers[0].action === "put" + ) { + const subscriber = mVars[id].subscribers.shift(); + mVars[id].value = subscriber.value; + request.respond(200); + } + + request.respond(200, null, value.buffer); + } +}); + +server.post("putMVar", (request) => { + const id = request.requestHeaders.getHeader("id"); + const value = request.body; + if (typeof mVars[id].value === "undefined") { + mVars[id].value = value; + + mVars[id].subscribers = mVars[id].subscribers.filter((subscriber) => { + if (subscriber.action === "read") { + subscriber.request.respond(200, null, value.buffer); + } + + return subscriber.action !== "read"; + }); + + const subscriber = mVars[id].subscribers.shift(); + + if (subscriber) { + subscriber.request.respond(200, null, value.buffer); + + if (subscriber.action === "take") { + mVars[id].value = undefined; + } + } + + request.respond(200); + } else { + mVars[id].subscribers.push({ action: "put", request, value }); + } +}); + +// NODE.JS SPECIFIC +server.post("nodeGetDirname", (request) => { + request.respond(200, null, __dirname); +}); + +server.post("nodeMathRandom", (request) => { + request.respond(200, null, Math.random()); +}); + +server.setDefaultHandler((request) => { + const url = new URL(request.url); + const client = url.protocol == "https:" ? https : http; + + const req = client.request(url, { + method: request.method, + headers: request.requestHeaders + }, (res) => { + let chunks = []; + + res.on("data", (chunk) => { + chunks.push(chunk); + }); + + res.on("end", () => { + const buffer = Buffer.concat(chunks); + const encoding = res.headers["content-encoding"]; + + if (encoding == "gzip") { + zlib.gunzip(buffer, (err, decoded) => { + if (err) throw err; + request.respond(200, null, decoded && decoded.toString()); + }); + } else if (encoding == "deflate") { + zlib.inflate(buffer, (err, decoded) => { + if (err) throw err; + request.respond(200, null, decoded && decoded.toString()); + }); + } else { + request.respond(200, null, buffer.toString()); + } + }); + }); + + req.on("error", (err) => { + throw err; + }); + + req.end(); +}); + +server.install(); + +const { Elm } = require("./guida.min.js"); + +Elm.Terminal.Main.init(); diff --git a/builder/src/BackgroundWriter.hs b/builder/src/BackgroundWriter.hs deleted file mode 100644 index 2bc7101c9e..0000000000 --- a/builder/src/BackgroundWriter.hs +++ /dev/null @@ -1,42 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -module BackgroundWriter - ( Scope - , withScope - , writeBinary - ) - where - - -import Control.Concurrent (forkIO) -import Control.Concurrent.MVar (MVar, newEmptyMVar, newMVar, putMVar, takeMVar) -import qualified Data.Binary as Binary -import Data.Foldable (traverse_) - -import qualified File - - - --- BACKGROUND WRITER - - -newtype Scope = - Scope (MVar [MVar ()]) - - -withScope :: (Scope -> IO a) -> IO a -withScope callback = - do workList <- newMVar [] - result <- callback (Scope workList) - mvars <- takeMVar workList - traverse_ takeMVar mvars - return result - - -writeBinary :: (Binary.Binary a) => Scope -> FilePath -> a -> IO () -writeBinary (Scope workList) path value = - do mvar <- newEmptyMVar - _ <- forkIO (File.writeBinary path value >> putMVar mvar ()) - oldWork <- takeMVar workList - let !newWork = mvar:oldWork - putMVar workList newWork - diff --git a/builder/src/Build.hs b/builder/src/Build.hs deleted file mode 100644 index 597f835e29..0000000000 --- a/builder/src/Build.hs +++ /dev/null @@ -1,1251 +0,0 @@ -{-# OPTIONS_GHC -Wno-unused-do-bind #-} -{-# LANGUAGE BangPatterns, GADTs, OverloadedStrings #-} -module Build - ( fromExposed - , fromPaths - , fromRepl - , Artifacts(..) - , Root(..) - , Module(..) - , CachedInterface(..) - , ReplArtifacts(..) - , DocsGoal(..) - , getRootNames - ) - where - - -import Control.Concurrent (forkIO) -import Control.Concurrent.MVar -import Control.Monad (filterM, mapM_, sequence_) -import qualified Data.ByteString as B -import qualified Data.Char as Char -import qualified Data.Graph as Graph -import qualified Data.List as List -import qualified Data.Map.Utils as Map -import qualified Data.Map.Strict as Map -import Data.Map.Strict ((!)) -import qualified Data.Maybe as Maybe -import qualified Data.Name as Name -import qualified Data.NonEmptyList as NE -import qualified Data.OneOrMore as OneOrMore -import qualified Data.Set as Set -import qualified System.Directory as Dir -import qualified System.FilePath as FP -import System.FilePath ((), (<.>)) - -import qualified AST.Canonical as Can -import qualified AST.Source as Src -import qualified AST.Optimized as Opt -import qualified Compile -import qualified Elm.Details as Details -import qualified Elm.Docs as Docs -import qualified Elm.Interface as I -import qualified Elm.ModuleName as ModuleName -import qualified Elm.Outline as Outline -import qualified Elm.Package as Pkg -import qualified File -import qualified Json.Encode as E -import qualified Parse.Module as Parse -import qualified Reporting -import qualified Reporting.Annotation as A -import qualified Reporting.Error as Error -import qualified Reporting.Error.Docs as EDocs -import qualified Reporting.Error.Syntax as Syntax -import qualified Reporting.Error.Import as Import -import qualified Reporting.Exit as Exit -import qualified Reporting.Render.Type.Localizer as L -import qualified Stuff - - - --- ENVIRONMENT - - -data Env = - Env - { _key :: Reporting.BKey - , _root :: FilePath - , _project :: Parse.ProjectType - , _srcDirs :: [AbsoluteSrcDir] - , _buildID :: Details.BuildID - , _locals :: Map.Map ModuleName.Raw Details.Local - , _foreigns :: Map.Map ModuleName.Raw Details.Foreign - } - - -makeEnv :: Reporting.BKey -> FilePath -> Details.Details -> IO Env -makeEnv key root (Details.Details _ validOutline buildID locals foreigns _) = - case validOutline of - Details.ValidApp givenSrcDirs -> - do srcDirs <- traverse (toAbsoluteSrcDir root) (NE.toList givenSrcDirs) - return $ Env key root Parse.Application srcDirs buildID locals foreigns - - Details.ValidPkg pkg _ _ -> - do srcDir <- toAbsoluteSrcDir root (Outline.RelativeSrcDir "src") - return $ Env key root (Parse.Package pkg) [srcDir] buildID locals foreigns - - - --- SOURCE DIRECTORY - - -newtype AbsoluteSrcDir = - AbsoluteSrcDir FilePath - - -toAbsoluteSrcDir :: FilePath -> Outline.SrcDir -> IO AbsoluteSrcDir -toAbsoluteSrcDir root srcDir = - AbsoluteSrcDir <$> Dir.canonicalizePath - ( - case srcDir of - Outline.AbsoluteSrcDir dir -> dir - Outline.RelativeSrcDir dir -> root dir - ) - - -addRelative :: AbsoluteSrcDir -> FilePath -> FilePath -addRelative (AbsoluteSrcDir srcDir) path = - srcDir path - - - --- FORK - - --- PERF try using IORef semephore on file crawl phase? --- described in Chapter 13 of Parallel and Concurrent Programming in Haskell by Simon Marlow --- https://www.oreilly.com/library/view/parallel-and-concurrent/9781449335939/ch13.html#sec_conc-par-overhead --- -fork :: IO a -> IO (MVar a) -fork work = - do mvar <- newEmptyMVar - _ <- forkIO $ putMVar mvar =<< work - return mvar - - -{-# INLINE forkWithKey #-} -forkWithKey :: (k -> a -> IO b) -> Map.Map k a -> IO (Map.Map k (MVar b)) -forkWithKey func dict = - Map.traverseWithKey (\k v -> fork (func k v)) dict - - - --- FROM EXPOSED - - -fromExposed :: Reporting.Style -> FilePath -> Details.Details -> DocsGoal docs -> NE.List ModuleName.Raw -> IO (Either Exit.BuildProblem docs) -fromExposed style root details docsGoal exposed@(NE.List e es) = - Reporting.trackBuild style $ \key -> - do env <- makeEnv key root details - dmvar <- Details.loadInterfaces root details - - -- crawl - mvar <- newEmptyMVar - let docsNeed = toDocsNeed docsGoal - roots <- Map.fromKeysA (fork . crawlModule env mvar docsNeed) (e:es) - putMVar mvar roots - mapM_ readMVar roots - statuses <- traverse readMVar =<< readMVar mvar - - -- compile - midpoint <- checkMidpoint dmvar statuses - case midpoint of - Left problem -> - return (Left (Exit.BuildProjectProblem problem)) - - Right foreigns -> - do rmvar <- newEmptyMVar - resultMVars <- forkWithKey (checkModule env foreigns rmvar) statuses - putMVar rmvar resultMVars - results <- traverse readMVar resultMVars - writeDetails root details results - finalizeExposed root docsGoal exposed results - - - --- FROM PATHS - - -data Artifacts = - Artifacts - { _name :: Pkg.Name - , _deps :: Dependencies - , _roots :: NE.List Root - , _modules :: [Module] - } - - -data Module - = Fresh ModuleName.Raw I.Interface Opt.LocalGraph - | Cached ModuleName.Raw Bool (MVar CachedInterface) - - -type Dependencies = - Map.Map ModuleName.Canonical I.DependencyInterface - - -fromPaths :: Reporting.Style -> FilePath -> Details.Details -> NE.List FilePath -> IO (Either Exit.BuildProblem Artifacts) -fromPaths style root details paths = - Reporting.trackBuild style $ \key -> - do env <- makeEnv key root details - - elroots <- findRoots env paths - case elroots of - Left problem -> - return (Left (Exit.BuildProjectProblem problem)) - - Right lroots -> - do -- crawl - dmvar <- Details.loadInterfaces root details - smvar <- newMVar Map.empty - srootMVars <- traverse (fork . crawlRoot env smvar) lroots - sroots <- traverse readMVar srootMVars - statuses <- traverse readMVar =<< readMVar smvar - - midpoint <- checkMidpointAndRoots dmvar statuses sroots - case midpoint of - Left problem -> - return (Left (Exit.BuildProjectProblem problem)) - - Right foreigns -> - do -- compile - rmvar <- newEmptyMVar - resultsMVars <- forkWithKey (checkModule env foreigns rmvar) statuses - putMVar rmvar resultsMVars - rrootMVars <- traverse (fork . checkRoot env resultsMVars) sroots - results <- traverse readMVar resultsMVars - writeDetails root details results - toArtifacts env foreigns results <$> traverse readMVar rrootMVars - - - --- GET ROOT NAMES - - -getRootNames :: Artifacts -> NE.List ModuleName.Raw -getRootNames (Artifacts _ _ roots _) = - fmap getRootName roots - - -getRootName :: Root -> ModuleName.Raw -getRootName root = - case root of - Inside name -> name - Outside name _ _ -> name - - - --- CRAWL - - -type StatusDict = - Map.Map ModuleName.Raw (MVar Status) - - -data Status - = SCached Details.Local - | SChanged Details.Local B.ByteString Src.Module DocsNeed - | SBadImport Import.Problem - | SBadSyntax FilePath File.Time B.ByteString Syntax.Error - | SForeign Pkg.Name - | SKernel - - -crawlDeps :: Env -> MVar StatusDict -> [ModuleName.Raw] -> a -> IO a -crawlDeps env mvar deps blockedValue = - do statusDict <- takeMVar mvar - let depsDict = Map.fromKeys (\_ -> ()) deps - let newsDict = Map.difference depsDict statusDict - statuses <- Map.traverseWithKey crawlNew newsDict - putMVar mvar (Map.union statuses statusDict) - mapM_ readMVar statuses - return blockedValue - where - crawlNew name () = fork (crawlModule env mvar (DocsNeed False) name) - - -crawlModule :: Env -> MVar StatusDict -> DocsNeed -> ModuleName.Raw -> IO Status -crawlModule env@(Env _ root projectType srcDirs buildID locals foreigns) mvar docsNeed name = - do let fileName = ModuleName.toFilePath name <.> "elm" - - paths <- filterM File.exists (map (`addRelative` fileName) srcDirs) - - case paths of - [path] -> - case Map.lookup name foreigns of - Just (Details.Foreign dep deps) -> - return $ SBadImport $ Import.Ambiguous path [] dep deps - - Nothing -> - do newTime <- File.getTime path - case Map.lookup name locals of - Nothing -> - crawlFile env mvar docsNeed name path newTime buildID - - Just local@(Details.Local oldPath oldTime deps _ lastChange _) -> - if path /= oldPath || oldTime /= newTime || needsDocs docsNeed - then crawlFile env mvar docsNeed name path newTime lastChange - else crawlDeps env mvar deps (SCached local) - - p1:p2:ps -> - return $ SBadImport $ Import.AmbiguousLocal (FP.makeRelative root p1) (FP.makeRelative root p2) (map (FP.makeRelative root) ps) - - [] -> - case Map.lookup name foreigns of - Just (Details.Foreign dep deps) -> - case deps of - [] -> - return $ SForeign dep - - d:ds -> - return $ SBadImport $ Import.AmbiguousForeign dep d ds - - Nothing -> - if Name.isKernel name && Parse.isKernel projectType then - do exists <- File.exists ("src" ModuleName.toFilePath name <.> "js") - return $ if exists then SKernel else SBadImport Import.NotFound - else - return $ SBadImport Import.NotFound - - -crawlFile :: Env -> MVar StatusDict -> DocsNeed -> ModuleName.Raw -> FilePath -> File.Time -> Details.BuildID -> IO Status -crawlFile env@(Env _ root projectType _ buildID _ _) mvar docsNeed expectedName path time lastChange = - do source <- File.readUtf8 (root path) - - case Parse.fromByteString projectType source of - Left err -> - return $ SBadSyntax path time source err - - Right modul@(Src.Module maybeActualName _ _ imports values _ _ _ _) -> - case maybeActualName of - Nothing -> - return $ SBadSyntax path time source (Syntax.ModuleNameUnspecified expectedName) - - Just name@(A.At _ actualName) -> - if expectedName == actualName then - let - deps = map Src.getImportName imports - local = Details.Local path time deps (any isMain values) lastChange buildID - in - crawlDeps env mvar deps (SChanged local source modul docsNeed) - else - return $ SBadSyntax path time source (Syntax.ModuleNameMismatch expectedName name) - - -isMain :: A.Located Src.Value -> Bool -isMain (A.At _ (Src.Value (A.At _ name) _ _ _)) = - name == Name._main - - - --- CHECK MODULE - - -type ResultDict = - Map.Map ModuleName.Raw (MVar Result) - - -data Result - = RNew !Details.Local !I.Interface !Opt.LocalGraph !(Maybe Docs.Module) - | RSame !Details.Local !I.Interface !Opt.LocalGraph !(Maybe Docs.Module) - | RCached Bool Details.BuildID (MVar CachedInterface) - | RNotFound Import.Problem - | RProblem Error.Module - | RBlocked - | RForeign I.Interface - | RKernel - - -data CachedInterface - = Unneeded - | Loaded I.Interface - | Corrupted - - -checkModule :: Env -> Dependencies -> MVar ResultDict -> ModuleName.Raw -> Status -> IO Result -checkModule env@(Env _ root projectType _ _ _ _) foreigns resultsMVar name status = - case status of - SCached local@(Details.Local path time deps hasMain lastChange lastCompile) -> - do results <- readMVar resultsMVar - depsStatus <- checkDeps root results deps lastCompile - case depsStatus of - DepsChange ifaces -> - do source <- File.readUtf8 path - case Parse.fromByteString projectType source of - Right modul -> compile env (DocsNeed False) local source ifaces modul - Left err -> - return $ RProblem $ - Error.Module name path time source (Error.BadSyntax err) - - DepsSame _ _ -> - do mvar <- newMVar Unneeded - return (RCached hasMain lastChange mvar) - - DepsBlock -> - return RBlocked - - DepsNotFound problems -> - do source <- File.readUtf8 path - return $ RProblem $ Error.Module name path time source $ - case Parse.fromByteString projectType source of - Right (Src.Module _ _ _ imports _ _ _ _ _) -> - Error.BadImports (toImportErrors env results imports problems) - - Left err -> - Error.BadSyntax err - - SChanged local@(Details.Local path time deps _ _ lastCompile) source modul@(Src.Module _ _ _ imports _ _ _ _ _) docsNeed -> - do results <- readMVar resultsMVar - depsStatus <- checkDeps root results deps lastCompile - case depsStatus of - DepsChange ifaces -> - compile env docsNeed local source ifaces modul - - DepsSame same cached -> - do maybeLoaded <- loadInterfaces root same cached - case maybeLoaded of - Nothing -> return RBlocked - Just ifaces -> compile env docsNeed local source ifaces modul - - DepsBlock -> - return RBlocked - - DepsNotFound problems -> - return $ RProblem $ Error.Module name path time source $ - Error.BadImports (toImportErrors env results imports problems) - - SBadImport importProblem -> - return (RNotFound importProblem) - - SBadSyntax path time source err -> - return $ RProblem $ Error.Module name path time source $ - Error.BadSyntax err - - SForeign home -> - case foreigns ! ModuleName.Canonical home name of - I.Public iface -> return (RForeign iface) - I.Private _ _ _ -> error $ "mistakenly seeing private interface for " ++ Pkg.toChars home ++ " " ++ ModuleName.toChars name - - SKernel -> - return RKernel - - - --- CHECK DEPS - - -data DepsStatus - = DepsChange (Map.Map ModuleName.Raw I.Interface) - | DepsSame [Dep] [CDep] - | DepsBlock - | DepsNotFound (NE.List (ModuleName.Raw, Import.Problem)) - - -checkDeps :: FilePath -> ResultDict -> [ModuleName.Raw] -> Details.BuildID -> IO DepsStatus -checkDeps root results deps lastCompile = - checkDepsHelp root results deps [] [] [] [] False 0 lastCompile - - -type Dep = (ModuleName.Raw, I.Interface) -type CDep = (ModuleName.Raw, MVar CachedInterface) - - -checkDepsHelp :: FilePath -> ResultDict -> [ModuleName.Raw] -> [Dep] -> [Dep] -> [CDep] -> [(ModuleName.Raw,Import.Problem)] -> Bool -> Details.BuildID -> Details.BuildID -> IO DepsStatus -checkDepsHelp root results deps new same cached importProblems isBlocked lastDepChange lastCompile = - case deps of - dep:otherDeps -> - do result <- readMVar (results ! dep) - case result of - RNew (Details.Local _ _ _ _ lastChange _) iface _ _ -> - checkDepsHelp root results otherDeps ((dep,iface) : new) same cached importProblems isBlocked (max lastChange lastDepChange) lastCompile - - RSame (Details.Local _ _ _ _ lastChange _) iface _ _ -> - checkDepsHelp root results otherDeps new ((dep,iface) : same) cached importProblems isBlocked (max lastChange lastDepChange) lastCompile - - RCached _ lastChange mvar -> - checkDepsHelp root results otherDeps new same ((dep,mvar) : cached) importProblems isBlocked (max lastChange lastDepChange) lastCompile - - RNotFound prob -> - checkDepsHelp root results otherDeps new same cached ((dep,prob) : importProblems) True lastDepChange lastCompile - - RProblem _ -> - checkDepsHelp root results otherDeps new same cached importProblems True lastDepChange lastCompile - - RBlocked -> - checkDepsHelp root results otherDeps new same cached importProblems True lastDepChange lastCompile - - RForeign iface -> - checkDepsHelp root results otherDeps new ((dep,iface) : same) cached importProblems isBlocked lastDepChange lastCompile - - RKernel -> - checkDepsHelp root results otherDeps new same cached importProblems isBlocked lastDepChange lastCompile - - - [] -> - case reverse importProblems of - p:ps -> - return $ DepsNotFound (NE.List p ps) - - [] -> - if isBlocked then - return $ DepsBlock - - else if null new && lastDepChange <= lastCompile then - return $ DepsSame same cached - - else - do maybeLoaded <- loadInterfaces root same cached - case maybeLoaded of - Nothing -> return DepsBlock - Just ifaces -> return $ DepsChange $ Map.union (Map.fromList new) ifaces - - - --- TO IMPORT ERROR - - -toImportErrors :: Env -> ResultDict -> [Src.Import] -> NE.List (ModuleName.Raw, Import.Problem) -> NE.List Import.Error -toImportErrors (Env _ _ _ _ _ locals foreigns) results imports problems = - let - knownModules = - Set.unions - [ Map.keysSet foreigns - , Map.keysSet locals - , Map.keysSet results - ] - - unimportedModules = - Set.difference knownModules (Set.fromList (map Src.getImportName imports)) - - regionDict = - Map.fromList (map (\(Src.Import (A.At region name) _ _) -> (name, region)) imports) - - toError (name, problem) = - Import.Error (regionDict ! name) name unimportedModules problem - in - fmap toError problems - - - --- LOAD CACHED INTERFACES - - -loadInterfaces :: FilePath -> [Dep] -> [CDep] -> IO (Maybe (Map.Map ModuleName.Raw I.Interface)) -loadInterfaces root same cached = - do loading <- traverse (fork . loadInterface root) cached - maybeLoaded <- traverse readMVar loading - case sequence maybeLoaded of - Nothing -> - return Nothing - - Just loaded -> - return $ Just $ Map.union (Map.fromList loaded) (Map.fromList same) - - -loadInterface :: FilePath -> CDep -> IO (Maybe Dep) -loadInterface root (name, ciMvar) = - do cachedInterface <- takeMVar ciMvar - case cachedInterface of - Corrupted -> - do putMVar ciMvar cachedInterface - return Nothing - - Loaded iface -> - do putMVar ciMvar cachedInterface - return (Just (name, iface)) - - Unneeded -> - do maybeIface <- File.readBinary (Stuff.elmi root name) - case maybeIface of - Nothing -> - do putMVar ciMvar Corrupted - return Nothing - - Just iface -> - do putMVar ciMvar (Loaded iface) - return (Just (name, iface)) - - - --- CHECK PROJECT - - -checkMidpoint :: MVar (Maybe Dependencies) -> Map.Map ModuleName.Raw Status -> IO (Either Exit.BuildProjectProblem Dependencies) -checkMidpoint dmvar statuses = - case checkForCycles statuses of - Nothing -> - do maybeForeigns <- readMVar dmvar - case maybeForeigns of - Nothing -> return (Left Exit.BP_CannotLoadDependencies) - Just fs -> return (Right fs) - - Just (NE.List name names) -> - do _ <- readMVar dmvar - return (Left (Exit.BP_Cycle name names)) - - -checkMidpointAndRoots :: MVar (Maybe Dependencies) -> Map.Map ModuleName.Raw Status -> NE.List RootStatus -> IO (Either Exit.BuildProjectProblem Dependencies) -checkMidpointAndRoots dmvar statuses sroots = - case checkForCycles statuses of - Nothing -> - case checkUniqueRoots statuses sroots of - Nothing -> - do maybeForeigns <- readMVar dmvar - case maybeForeigns of - Nothing -> return (Left Exit.BP_CannotLoadDependencies) - Just fs -> return (Right fs) - - Just problem -> - do _ <- readMVar dmvar - return (Left problem) - - Just (NE.List name names) -> - do _ <- readMVar dmvar - return (Left (Exit.BP_Cycle name names)) - - - --- CHECK FOR CYCLES - - -checkForCycles :: Map.Map ModuleName.Raw Status -> Maybe (NE.List ModuleName.Raw) -checkForCycles modules = - let - !graph = Map.foldrWithKey addToGraph [] modules - !sccs = Graph.stronglyConnComp graph - in - checkForCyclesHelp sccs - - -checkForCyclesHelp :: [Graph.SCC ModuleName.Raw] -> Maybe (NE.List ModuleName.Raw) -checkForCyclesHelp sccs = - case sccs of - [] -> - Nothing - - scc:otherSccs -> - case scc of - Graph.AcyclicSCC _ -> checkForCyclesHelp otherSccs - Graph.CyclicSCC [] -> checkForCyclesHelp otherSccs - Graph.CyclicSCC (m:ms) -> Just (NE.List m ms) - - -type Node = - ( ModuleName.Raw, ModuleName.Raw, [ModuleName.Raw] ) - - -addToGraph :: ModuleName.Raw -> Status -> [Node] -> [Node] -addToGraph name status graph = - let - dependencies = - case status of - SCached (Details.Local _ _ deps _ _ _) -> deps - SChanged (Details.Local _ _ deps _ _ _) _ _ _ -> deps - SBadImport _ -> [] - SBadSyntax _ _ _ _ -> [] - SForeign _ -> [] - SKernel -> [] - in - (name, name, dependencies) : graph - - - --- CHECK UNIQUE ROOTS - - -checkUniqueRoots :: Map.Map ModuleName.Raw Status -> NE.List RootStatus -> Maybe Exit.BuildProjectProblem -checkUniqueRoots insides sroots = - let - outsidesDict = - Map.fromListWith OneOrMore.more (Maybe.mapMaybe rootStatusToNamePathPair (NE.toList sroots)) - in - case Map.traverseWithKey checkOutside outsidesDict of - Left problem -> - Just problem - - Right outsides -> - case sequence_ (Map.intersectionWithKey checkInside outsides insides) of - Right () -> Nothing - Left problem -> Just problem - - -rootStatusToNamePathPair :: RootStatus -> Maybe (ModuleName.Raw, OneOrMore.OneOrMore FilePath) -rootStatusToNamePathPair sroot = - case sroot of - SInside _ -> Nothing - SOutsideOk (Details.Local path _ _ _ _ _) _ modul -> Just (Src.getName modul, OneOrMore.one path) - SOutsideErr _ -> Nothing - - -checkOutside :: ModuleName.Raw -> OneOrMore.OneOrMore FilePath -> Either Exit.BuildProjectProblem FilePath -checkOutside name paths = - case OneOrMore.destruct NE.List paths of - NE.List p [] -> Right p - NE.List p1 (p2:_) -> Left (Exit.BP_RootNameDuplicate name p1 p2) - - -checkInside :: ModuleName.Raw -> FilePath -> Status -> Either Exit.BuildProjectProblem () -checkInside name p1 status = - case status of - SCached (Details.Local p2 _ _ _ _ _) -> Left (Exit.BP_RootNameDuplicate name p1 p2) - SChanged (Details.Local p2 _ _ _ _ _) _ _ _ -> Left (Exit.BP_RootNameDuplicate name p1 p2) - SBadImport _ -> Right () - SBadSyntax _ _ _ _ -> Right () - SForeign _ -> Right () - SKernel -> Right () - - - --- COMPILE MODULE - - -compile :: Env -> DocsNeed -> Details.Local -> B.ByteString -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> IO Result -compile (Env key root projectType _ buildID _ _) docsNeed (Details.Local path time deps main lastChange _) source ifaces modul = - let - pkg = projectTypeToPkg projectType - in - case Compile.compile pkg ifaces modul of - Right (Compile.Artifacts canonical annotations objects) -> - case makeDocs docsNeed canonical of - Left err -> - return $ RProblem $ - Error.Module (Src.getName modul) path time source (Error.BadDocs err) - - Right docs -> - do let name = Src.getName modul - let iface = I.fromModule pkg canonical annotations - let elmi = Stuff.elmi root name - File.writeBinary (Stuff.elmo root name) objects - maybeOldi <- File.readBinary elmi - case maybeOldi of - Just oldi | oldi == iface -> - do -- iface should be fully forced by equality check - Reporting.report key Reporting.BDone - let local = Details.Local path time deps main lastChange buildID - return (RSame local iface objects docs) - - _ -> - do -- iface may be lazy still - File.writeBinary elmi iface - Reporting.report key Reporting.BDone - let local = Details.Local path time deps main buildID buildID - return (RNew local iface objects docs) - - Left err -> - return $ RProblem $ - Error.Module (Src.getName modul) path time source err - - -projectTypeToPkg :: Parse.ProjectType -> Pkg.Name -projectTypeToPkg projectType = - case projectType of - Parse.Package pkg -> pkg - Parse.Application -> Pkg.dummyName - - - --- WRITE DETAILS - - -writeDetails :: FilePath -> Details.Details -> Map.Map ModuleName.Raw Result -> IO () -writeDetails root (Details.Details time outline buildID locals foreigns extras) results = - File.writeBinary (Stuff.details root) $ - Details.Details time outline buildID (Map.foldrWithKey addNewLocal locals results) foreigns extras - - -addNewLocal :: ModuleName.Raw -> Result -> Map.Map ModuleName.Raw Details.Local -> Map.Map ModuleName.Raw Details.Local -addNewLocal name result locals = - case result of - RNew local _ _ _ -> Map.insert name local locals - RSame local _ _ _ -> Map.insert name local locals - RCached _ _ _ -> locals - RNotFound _ -> locals - RProblem _ -> locals - RBlocked -> locals - RForeign _ -> locals - RKernel -> locals - - - --- FINALIZE EXPOSED - - -finalizeExposed :: FilePath -> DocsGoal docs -> NE.List ModuleName.Raw -> Map.Map ModuleName.Raw Result -> IO (Either Exit.BuildProblem docs) -finalizeExposed root docsGoal exposed results = - case foldr (addImportProblems results) [] (NE.toList exposed) of - p:ps -> - return $ Left $ Exit.BuildProjectProblem (Exit.BP_MissingExposed (NE.List p ps)) - - [] -> - case Map.foldr addErrors [] results of - [] -> Right <$> finalizeDocs docsGoal results - e:es -> return $ Left $ Exit.BuildBadModules root e es - - -addErrors :: Result -> [Error.Module] -> [Error.Module] -addErrors result errors = - case result of - RNew _ _ _ _ -> errors - RSame _ _ _ _ -> errors - RCached _ _ _ -> errors - RNotFound _ -> errors - RProblem e -> e:errors - RBlocked -> errors - RForeign _ -> errors - RKernel -> errors - - -addImportProblems :: Map.Map ModuleName.Raw Result -> ModuleName.Raw -> [(ModuleName.Raw, Import.Problem)] -> [(ModuleName.Raw, Import.Problem)] -addImportProblems results name problems = - case results ! name of - RNew _ _ _ _ -> problems - RSame _ _ _ _ -> problems - RCached _ _ _ -> problems - RNotFound p -> (name, p) : problems - RProblem _ -> problems - RBlocked -> problems - RForeign _ -> problems - RKernel -> problems - - - --- DOCS - - -data DocsGoal a where - KeepDocs :: DocsGoal Docs.Documentation - WriteDocs :: FilePath -> DocsGoal () - IgnoreDocs :: DocsGoal () - - -newtype DocsNeed = - DocsNeed { needsDocs :: Bool } - - -toDocsNeed :: DocsGoal a -> DocsNeed -toDocsNeed goal = - case goal of - IgnoreDocs -> DocsNeed False - WriteDocs _ -> DocsNeed True - KeepDocs -> DocsNeed True - - -makeDocs :: DocsNeed -> Can.Module -> Either EDocs.Error (Maybe Docs.Module) -makeDocs (DocsNeed isNeeded) modul = - if isNeeded then - case Docs.fromModule modul of - Right docs -> Right (Just docs) - Left err -> Left err - else - Right Nothing - - -finalizeDocs :: DocsGoal docs -> Map.Map ModuleName.Raw Result -> IO docs -finalizeDocs goal results = - case goal of - KeepDocs -> - return $ Map.mapMaybe toDocs results - - WriteDocs path -> - E.writeUgly path $ Docs.encode $ Map.mapMaybe toDocs results - - IgnoreDocs -> - return () - - -toDocs :: Result -> Maybe Docs.Module -toDocs result = - case result of - RNew _ _ _ d -> d - RSame _ _ _ d -> d - RCached _ _ _ -> Nothing - RNotFound _ -> Nothing - RProblem _ -> Nothing - RBlocked -> Nothing - RForeign _ -> Nothing - RKernel -> Nothing - - - --------------------------------------------------------------------------------- ------- NOW FOR SOME REPL STUFF ------------------------------------------------- --------------------------------------------------------------------------------- - - --- FROM REPL - - -data ReplArtifacts = - ReplArtifacts - { _repl_home :: ModuleName.Canonical - , _repl_modules :: [Module] - , _repl_localizer :: L.Localizer - , _repl_annotations :: Map.Map Name.Name Can.Annotation - } - - -fromRepl :: FilePath -> Details.Details -> B.ByteString -> IO (Either Exit.Repl ReplArtifacts) -fromRepl root details source = - do env@(Env _ _ projectType _ _ _ _) <- makeEnv Reporting.ignorer root details - case Parse.fromByteString projectType source of - Left syntaxError -> - return $ Left $ Exit.ReplBadInput source $ Error.BadSyntax syntaxError - - Right modul@(Src.Module _ _ _ imports _ _ _ _ _) -> - do dmvar <- Details.loadInterfaces root details - - let deps = map Src.getImportName imports - mvar <- newMVar Map.empty - crawlDeps env mvar deps () - - statuses <- traverse readMVar =<< readMVar mvar - midpoint <- checkMidpoint dmvar statuses - - case midpoint of - Left problem -> - return $ Left $ Exit.ReplProjectProblem problem - - Right foreigns -> - do rmvar <- newEmptyMVar - resultMVars <- forkWithKey (checkModule env foreigns rmvar) statuses - putMVar rmvar resultMVars - results <- traverse readMVar resultMVars - writeDetails root details results - depsStatus <- checkDeps root resultMVars deps 0 - finalizeReplArtifacts env source modul depsStatus resultMVars results - - -finalizeReplArtifacts :: Env -> B.ByteString -> Src.Module -> DepsStatus -> ResultDict -> Map.Map ModuleName.Raw Result -> IO (Either Exit.Repl ReplArtifacts) -finalizeReplArtifacts env@(Env _ root projectType _ _ _ _) source modul@(Src.Module _ _ _ imports _ _ _ _ _) depsStatus resultMVars results = - let - pkg = - projectTypeToPkg projectType - - compileInput ifaces = - case Compile.compile pkg ifaces modul of - Right (Compile.Artifacts canonical annotations objects) -> - let - h = Can._name canonical - m = Fresh (Src.getName modul) (I.fromModule pkg canonical annotations) objects - ms = Map.foldrWithKey addInside [] results - in - return $ Right $ ReplArtifacts h (m:ms) (L.fromModule modul) annotations - - Left errors -> - return $ Left $ Exit.ReplBadInput source errors - in - case depsStatus of - DepsChange ifaces -> - compileInput ifaces - - DepsSame same cached -> - do maybeLoaded <- loadInterfaces root same cached - case maybeLoaded of - Just ifaces -> compileInput ifaces - Nothing -> return $ Left $ Exit.ReplBadCache - - DepsBlock -> - case Map.foldr addErrors [] results of - [] -> return $ Left $ Exit.ReplBlocked - e:es -> return $ Left $ Exit.ReplBadLocalDeps root e es - - DepsNotFound problems -> - return $ Left $ Exit.ReplBadInput source $ Error.BadImports $ - toImportErrors env resultMVars imports problems - - - --------------------------------------------------------------------------------- --------------------------------------------------------------------------------- ------- AFTER THIS, EVERYTHING IS ABOUT HANDLING MODULES GIVEN BY FILEPATH ------ --------------------------------------------------------------------------------- --------------------------------------------------------------------------------- - - - --- FIND ROOT - - -data RootLocation - = LInside ModuleName.Raw - | LOutside FilePath - - -findRoots :: Env -> NE.List FilePath -> IO (Either Exit.BuildProjectProblem (NE.List RootLocation)) -findRoots env paths = - do mvars <- traverse (fork . getRootInfo env) paths - einfos <- traverse readMVar mvars - return $ checkRoots =<< sequence einfos - - -checkRoots :: NE.List RootInfo -> Either Exit.BuildProjectProblem (NE.List RootLocation) -checkRoots infos = - let - toOneOrMore loc@(RootInfo absolute _ _) = - (absolute, OneOrMore.one loc) - - fromOneOrMore loc locs = - case locs of - [] -> Right () - loc2:_ -> Left (Exit.BP_MainPathDuplicate (_relative loc) (_relative loc2)) - in - fmap (\_ -> fmap _location infos) $ - traverse (OneOrMore.destruct fromOneOrMore) $ - Map.fromListWith OneOrMore.more $ map toOneOrMore (NE.toList infos) - - - --- ROOT INFO - - -data RootInfo = - RootInfo - { _absolute :: FilePath - , _relative :: FilePath - , _location :: RootLocation - } - - -getRootInfo :: Env -> FilePath -> IO (Either Exit.BuildProjectProblem RootInfo) -getRootInfo env path = - do exists <- File.exists path - if exists - then getRootInfoHelp env path =<< Dir.canonicalizePath path - else return (Left (Exit.BP_PathUnknown path)) - - -getRootInfoHelp :: Env -> FilePath -> FilePath -> IO (Either Exit.BuildProjectProblem RootInfo) -getRootInfoHelp (Env _ _ _ srcDirs _ _ _) path absolutePath = - let - (dirs, file) = FP.splitFileName absolutePath - (final, ext) = FP.splitExtension file - in - if ext /= ".elm" - then - return $ Left $ Exit.BP_WithBadExtension path - else - let - absoluteSegments = FP.splitDirectories dirs ++ [final] - in - case Maybe.mapMaybe (isInsideSrcDirByPath absoluteSegments) srcDirs of - [] -> - return $ Right $ RootInfo absolutePath path (LOutside path) - - [(_, Right names)] -> - do let name = Name.fromChars (List.intercalate "." names) - matchingDirs <- filterM (isInsideSrcDirByName names) srcDirs - case matchingDirs of - d1:d2:_ -> - do let p1 = addRelative d1 (FP.joinPath names <.> "elm") - let p2 = addRelative d2 (FP.joinPath names <.> "elm") - return $ Left $ Exit.BP_RootNameDuplicate name p1 p2 - - _ -> - return $ Right $ RootInfo absolutePath path (LInside name) - - [(s, Left names)] -> - return $ Left $ Exit.BP_RootNameInvalid path s names - - (s1,_):(s2,_):_ -> - return $ Left $ Exit.BP_WithAmbiguousSrcDir path s1 s2 - - - -isInsideSrcDirByName :: [String] -> AbsoluteSrcDir -> IO Bool -isInsideSrcDirByName names srcDir = - File.exists (addRelative srcDir (FP.joinPath names <.> "elm")) - - -isInsideSrcDirByPath :: [String] -> AbsoluteSrcDir -> Maybe (FilePath, Either [String] [String]) -isInsideSrcDirByPath segments (AbsoluteSrcDir srcDir) = - case dropPrefix (FP.splitDirectories srcDir) segments of - Nothing -> - Nothing - - Just names -> - if all isGoodName names - then Just (srcDir, Right names) - else Just (srcDir, Left names) - - -isGoodName :: [Char] -> Bool -isGoodName name = - case name of - [] -> - False - - char:chars -> - Char.isUpper char && all (\c -> Char.isAlphaNum c || c == '_') chars - - --- INVARIANT: Dir.canonicalizePath has been run on both inputs --- -dropPrefix :: [FilePath] -> [FilePath] -> Maybe [FilePath] -dropPrefix roots paths = - case roots of - [] -> - Just paths - - r:rs -> - case paths of - [] -> Nothing - p:ps -> if r == p then dropPrefix rs ps else Nothing - - - --- CRAWL ROOTS - - -data RootStatus - = SInside ModuleName.Raw - | SOutsideOk Details.Local B.ByteString Src.Module - | SOutsideErr Error.Module - - -crawlRoot :: Env -> MVar StatusDict -> RootLocation -> IO RootStatus -crawlRoot env@(Env _ _ projectType _ buildID _ _) mvar root = - case root of - LInside name -> - do statusMVar <- newEmptyMVar - statusDict <- takeMVar mvar - putMVar mvar (Map.insert name statusMVar statusDict) - putMVar statusMVar =<< crawlModule env mvar (DocsNeed False) name - return (SInside name) - - LOutside path -> - do time <- File.getTime path - source <- File.readUtf8 path - case Parse.fromByteString projectType source of - Right modul@(Src.Module _ _ _ imports values _ _ _ _) -> - do let deps = map Src.getImportName imports - let local = Details.Local path time deps (any isMain values) buildID buildID - crawlDeps env mvar deps (SOutsideOk local source modul) - - Left syntaxError -> - return $ SOutsideErr $ - Error.Module "???" path time source (Error.BadSyntax syntaxError) - - - --- CHECK ROOTS - - -data RootResult - = RInside ModuleName.Raw - | ROutsideOk ModuleName.Raw I.Interface Opt.LocalGraph - | ROutsideErr Error.Module - | ROutsideBlocked - - -checkRoot :: Env -> ResultDict -> RootStatus -> IO RootResult -checkRoot env@(Env _ root _ _ _ _ _) results rootStatus = - case rootStatus of - SInside name -> - return (RInside name) - - SOutsideErr err -> - return (ROutsideErr err) - - SOutsideOk local@(Details.Local path time deps _ _ lastCompile) source modul@(Src.Module _ _ _ imports _ _ _ _ _) -> - do depsStatus <- checkDeps root results deps lastCompile - case depsStatus of - DepsChange ifaces -> - compileOutside env local source ifaces modul - - DepsSame same cached -> - do maybeLoaded <- loadInterfaces root same cached - case maybeLoaded of - Nothing -> return ROutsideBlocked - Just ifaces -> compileOutside env local source ifaces modul - - DepsBlock -> - return ROutsideBlocked - - DepsNotFound problems -> - return $ ROutsideErr $ Error.Module (Src.getName modul) path time source $ - Error.BadImports (toImportErrors env results imports problems) - - -compileOutside :: Env -> Details.Local -> B.ByteString -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> IO RootResult -compileOutside (Env key _ projectType _ _ _ _) (Details.Local path time _ _ _ _) source ifaces modul = - let - pkg = projectTypeToPkg projectType - name = Src.getName modul - in - case Compile.compile pkg ifaces modul of - Right (Compile.Artifacts canonical annotations objects) -> - do Reporting.report key Reporting.BDone - return $ ROutsideOk name (I.fromModule pkg canonical annotations) objects - - Left errors -> - return $ ROutsideErr $ Error.Module name path time source errors - - - --- TO ARTIFACTS - - -data Root - = Inside ModuleName.Raw - | Outside ModuleName.Raw I.Interface Opt.LocalGraph - - -toArtifacts :: Env -> Dependencies -> Map.Map ModuleName.Raw Result -> NE.List RootResult -> Either Exit.BuildProblem Artifacts -toArtifacts (Env _ root projectType _ _ _ _) foreigns results rootResults = - case gatherProblemsOrMains results rootResults of - Left (NE.List e es) -> - Left (Exit.BuildBadModules root e es) - - Right roots -> - Right $ Artifacts (projectTypeToPkg projectType) foreigns roots $ - Map.foldrWithKey addInside (foldr addOutside [] rootResults) results - - -gatherProblemsOrMains :: Map.Map ModuleName.Raw Result -> NE.List RootResult -> Either (NE.List Error.Module) (NE.List Root) -gatherProblemsOrMains results (NE.List rootResult rootResults) = - let - addResult result (es, roots) = - case result of - RInside n -> ( es, Inside n : roots) - ROutsideOk n i o -> ( es, Outside n i o : roots) - ROutsideErr e -> (e:es, roots) - ROutsideBlocked -> ( es, roots) - - errors = Map.foldr addErrors [] results - in - case (rootResult, foldr addResult (errors, []) rootResults) of - (RInside n , ( [], ms)) -> Right (NE.List (Inside n) ms) - (RInside _ , (e:es, _ )) -> Left (NE.List e es) - (ROutsideOk n i o, ( [], ms)) -> Right (NE.List (Outside n i o) ms) - (ROutsideOk _ _ _, (e:es, _ )) -> Left (NE.List e es) - (ROutsideErr e , ( es, _ )) -> Left (NE.List e es) - (ROutsideBlocked , ( [], _ )) -> error "seems like elm-stuff/ is corrupted" - (ROutsideBlocked , (e:es, _ )) -> Left (NE.List e es) - - -addInside :: ModuleName.Raw -> Result -> [Module] -> [Module] -addInside name result modules = - case result of - RNew _ iface objs _ -> Fresh name iface objs : modules - RSame _ iface objs _ -> Fresh name iface objs : modules - RCached main _ mvar -> Cached name main mvar : modules - RNotFound _ -> error (badInside name) - RProblem _ -> error (badInside name) - RBlocked -> error (badInside name) - RForeign _ -> modules - RKernel -> modules - - -badInside :: ModuleName.Raw -> [Char] -badInside name = - "Error from `" ++ Name.toChars name ++ "` should have been reported already." - - -addOutside :: RootResult -> [Module] -> [Module] -addOutside root modules = - case root of - RInside _ -> modules - ROutsideOk name iface objs -> Fresh name iface objs : modules - ROutsideErr _ -> modules - ROutsideBlocked -> modules diff --git a/builder/src/Deps/Bump.hs b/builder/src/Deps/Bump.hs deleted file mode 100644 index a41f814e7d..0000000000 --- a/builder/src/Deps/Bump.hs +++ /dev/null @@ -1,37 +0,0 @@ -module Deps.Bump - ( getPossibilities - ) - where - - -import qualified Data.List as List - -import qualified Deps.Registry as Registry -import qualified Elm.Magnitude as M -import qualified Elm.Version as V - - - --- GET POSSIBILITIES - - -getPossibilities :: Registry.KnownVersions -> [(V.Version, V.Version, M.Magnitude)] -getPossibilities (Registry.KnownVersions latest previous) = - let - allVersions = reverse (latest:previous) - minorPoints = map last (List.groupBy sameMajor allVersions) - patchPoints = map last (List.groupBy sameMinor allVersions) - in - (latest, V.bumpMajor latest, M.MAJOR) - : map (\v -> (v, V.bumpMinor v, M.MINOR)) minorPoints - ++ map (\v -> (v, V.bumpPatch v, M.PATCH)) patchPoints - - -sameMajor :: V.Version -> V.Version -> Bool -sameMajor (V.Version major1 _ _) (V.Version major2 _ _) = - major1 == major2 - - -sameMinor :: V.Version -> V.Version -> Bool -sameMinor (V.Version major1 minor1 _) (V.Version major2 minor2 _) = - major1 == major2 && minor1 == minor2 diff --git a/builder/src/Deps/Diff.hs b/builder/src/Deps/Diff.hs deleted file mode 100644 index 6db4e71443..0000000000 --- a/builder/src/Deps/Diff.hs +++ /dev/null @@ -1,383 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module Deps.Diff - ( diff - , PackageChanges(..) - , ModuleChanges(..) - , Changes(..) - , moduleChangeMagnitude - , toMagnitude - , bump - , getDocs - ) - where - - -import Control.Monad (zipWithM) -import Data.Function (on) -import qualified Data.List as List -import qualified Data.Map as Map -import qualified Data.Name as Name -import qualified Data.Set as Set -import qualified System.Directory as Dir -import System.FilePath (()) - -import qualified Deps.Website as Website -import qualified Elm.Compiler.Type as Type -import qualified Elm.Docs as Docs -import qualified Elm.Magnitude as M -import qualified Elm.ModuleName as ModuleName -import qualified Elm.Package as Pkg -import qualified Elm.Version as V -import qualified File -import qualified Http -import qualified Json.Decode as D -import qualified Reporting.Exit as Exit -import qualified Stuff - - - --- CHANGES - - -data PackageChanges = - PackageChanges - { _modules_added :: [ModuleName.Raw] - , _modules_changed :: Map.Map ModuleName.Raw ModuleChanges - , _modules_removed :: [ModuleName.Raw] - } - - -data ModuleChanges = - ModuleChanges - { _unions :: Changes Name.Name Docs.Union - , _aliases :: Changes Name.Name Docs.Alias - , _values :: Changes Name.Name Docs.Value - , _binops :: Changes Name.Name Docs.Binop - } - - -data Changes k v = - Changes - { _added :: Map.Map k v - , _changed :: Map.Map k (v,v) - , _removed :: Map.Map k v - } - - -getChanges :: (Ord k) => (v -> v -> Bool) -> Map.Map k v -> Map.Map k v -> Changes k v -getChanges isEquivalent old new = - let - overlap = Map.intersectionWith (,) old new - changed = Map.filter (not . uncurry isEquivalent) overlap - in - Changes (Map.difference new old) changed (Map.difference old new) - - - --- DIFF - - -diff :: Docs.Documentation -> Docs.Documentation -> PackageChanges -diff oldDocs newDocs = - let - filterOutPatches chngs = - Map.filter (\chng -> moduleChangeMagnitude chng /= M.PATCH) chngs - - (Changes added changed removed) = - getChanges (\_ _ -> False) oldDocs newDocs - in - PackageChanges - (Map.keys added) - (filterOutPatches (Map.map diffModule changed)) - (Map.keys removed) - - - -diffModule :: (Docs.Module, Docs.Module) -> ModuleChanges -diffModule (Docs.Module _ _ u1 a1 v1 b1, Docs.Module _ _ u2 a2 v2 b2) = - ModuleChanges - (getChanges isEquivalentUnion u1 u2) - (getChanges isEquivalentAlias a1 a2) - (getChanges isEquivalentValue v1 v2) - (getChanges isEquivalentBinop b1 b2) - - - --- EQUIVALENCE - - -isEquivalentUnion :: Docs.Union -> Docs.Union -> Bool -isEquivalentUnion (Docs.Union oldComment oldVars oldCtors) (Docs.Union newComment newVars newCtors) = - length oldCtors == length newCtors - && and (zipWith (==) (map fst oldCtors) (map fst newCtors)) - && and (Map.elems (Map.intersectionWith equiv (Map.fromList oldCtors) (Map.fromList newCtors))) - where - equiv :: [Type.Type] -> [Type.Type] -> Bool - equiv oldTypes newTypes = - let - allEquivalent = - zipWith - isEquivalentAlias - (map (Docs.Alias oldComment oldVars) oldTypes) - (map (Docs.Alias newComment newVars) newTypes) - in - length oldTypes == length newTypes - && and allEquivalent - - -isEquivalentAlias :: Docs.Alias -> Docs.Alias -> Bool -isEquivalentAlias (Docs.Alias _ oldVars oldType) (Docs.Alias _ newVars newType) = - case diffType oldType newType of - Nothing -> - False - - Just renamings -> - length oldVars == length newVars - && isEquivalentRenaming (zip oldVars newVars ++ renamings) - - -isEquivalentValue :: Docs.Value -> Docs.Value -> Bool -isEquivalentValue (Docs.Value c1 t1) (Docs.Value c2 t2) = - isEquivalentAlias (Docs.Alias c1 [] t1) (Docs.Alias c2 [] t2) - - -isEquivalentBinop :: Docs.Binop -> Docs.Binop -> Bool -isEquivalentBinop (Docs.Binop c1 t1 a1 p1) (Docs.Binop c2 t2 a2 p2) = - isEquivalentAlias (Docs.Alias c1 [] t1) (Docs.Alias c2 [] t2) - && a1 == a2 - && p1 == p2 - - - --- DIFF TYPES - - -diffType :: Type.Type -> Type.Type -> Maybe [(Name.Name,Name.Name)] -diffType oldType newType = - case (oldType, newType) of - (Type.Var oldName, Type.Var newName) -> - Just [(oldName, newName)] - - (Type.Lambda a b, Type.Lambda a' b') -> - (++) - <$> diffType a a' - <*> diffType b b' - - (Type.Type oldName oldArgs, Type.Type newName newArgs) -> - if not (isSameName oldName newName) || length oldArgs /= length newArgs then - Nothing - else - concat <$> zipWithM diffType oldArgs newArgs - - (Type.Record fields maybeExt, Type.Record fields' maybeExt') -> - case (maybeExt, maybeExt') of - (Nothing, Just _) -> - Nothing - - (Just _, Nothing) -> - Nothing - - (Nothing, Nothing) -> - diffFields fields fields' - - (Just oldExt, Just newExt) -> - (:) (oldExt, newExt) <$> diffFields fields fields' - - (Type.Unit, Type.Unit) -> - Just [] - - (Type.Tuple a b cs, Type.Tuple x y zs) -> - if length cs /= length zs then - Nothing - else - do aVars <- diffType a x - bVars <- diffType b y - cVars <- concat <$> zipWithM diffType cs zs - return (aVars ++ bVars ++ cVars) - - (_, _) -> - Nothing - - --- handle very old docs that do not use qualified names -isSameName :: Name.Name -> Name.Name -> Bool -isSameName oldFullName newFullName = - let - dedot name = - reverse (Name.splitDots name) - in - case ( dedot oldFullName, dedot newFullName ) of - (oldName:[], newName:_) -> - oldName == newName - - (oldName:_, newName:[]) -> - oldName == newName - - _ -> - oldFullName == newFullName - - -diffFields :: [(Name.Name, Type.Type)] -> [(Name.Name, Type.Type)] -> Maybe [(Name.Name,Name.Name)] -diffFields oldRawFields newRawFields = - let - sort = List.sortBy (compare `on` fst) - oldFields = sort oldRawFields - newFields = sort newRawFields - in - if length oldRawFields /= length newRawFields then - Nothing - - else if or (zipWith ((/=) `on` fst) oldFields newFields) then - Nothing - - else - concat <$> zipWithM (diffType `on` snd) oldFields newFields - - - --- TYPE VARIABLES - - -isEquivalentRenaming :: [(Name.Name,Name.Name)] -> Bool -isEquivalentRenaming varPairs = - let - renamings = - Map.toList (foldr insert Map.empty varPairs) - - insert (old,new) dict = - Map.insertWith (++) old [new] dict - - verify (old, news) = - case news of - [] -> - Nothing - - new : rest -> - if all (new ==) rest then - Just (old, new) - else - Nothing - - allUnique list = - length list == Set.size (Set.fromList list) - in - case mapM verify renamings of - Nothing -> - False - - Just verifiedRenamings -> - all compatibleVars verifiedRenamings - && - allUnique (map snd verifiedRenamings) - - -compatibleVars :: (Name.Name, Name.Name) -> Bool -compatibleVars (old, new) = - case (categorizeVar old, categorizeVar new) of - (CompAppend, CompAppend) -> True - (Comparable, Comparable) -> True - (Appendable, Appendable) -> True - (Number , Number ) -> True - (Number , Comparable) -> True - - (_, Var) -> True - - (_, _) -> False - - -data TypeVarCategory - = CompAppend - | Comparable - | Appendable - | Number - | Var - - -categorizeVar :: Name.Name -> TypeVarCategory -categorizeVar name - | Name.isCompappendType name = CompAppend - | Name.isComparableType name = Comparable - | Name.isAppendableType name = Appendable - | Name.isNumberType name = Number - | otherwise = Var - - - --- MAGNITUDE - - -bump :: PackageChanges -> V.Version -> V.Version -bump changes version = - case toMagnitude changes of - M.PATCH -> - V.bumpPatch version - - M.MINOR -> - V.bumpMinor version - - M.MAJOR -> - V.bumpMajor version - - -toMagnitude :: PackageChanges -> M.Magnitude -toMagnitude (PackageChanges added changed removed) = - let - addMag = if null added then M.PATCH else M.MINOR - removeMag = if null removed then M.PATCH else M.MAJOR - changeMags = map moduleChangeMagnitude (Map.elems changed) - in - maximum (addMag : removeMag : changeMags) - - -moduleChangeMagnitude :: ModuleChanges -> M.Magnitude -moduleChangeMagnitude (ModuleChanges unions aliases values binops) = - maximum - [ changeMagnitude unions - , changeMagnitude aliases - , changeMagnitude values - , changeMagnitude binops - ] - - -changeMagnitude :: Changes k v -> M.Magnitude -changeMagnitude (Changes added changed removed) = - if Map.size removed > 0 || Map.size changed > 0 then - M.MAJOR - - else if Map.size added > 0 then - M.MINOR - - else - M.PATCH - - - --- GET DOCS - - -getDocs :: Stuff.PackageCache -> Http.Manager -> Pkg.Name -> V.Version -> IO (Either Exit.DocsProblem Docs.Documentation) -getDocs cache manager name version = - do let home = Stuff.package cache name version - let path = home "docs.json" - exists <- File.exists path - if exists - then - do bytes <- File.readUtf8 path - case D.fromByteString Docs.decoder bytes of - Right docs -> - return $ Right docs - - Left _ -> - do File.remove path - return $ Left Exit.DP_Cache - else - do let url = Website.metadata name version "docs.json" - Http.get manager url [] Exit.DP_Http $ \body -> - case D.fromByteString Docs.decoder body of - Right docs -> - do Dir.createDirectoryIfMissing True home - File.writeUtf8 path body - return $ Right docs - - Left _ -> - return $ Left $ Exit.DP_Data url body diff --git a/builder/src/Deps/Registry.hs b/builder/src/Deps/Registry.hs deleted file mode 100644 index 8d7def98be..0000000000 --- a/builder/src/Deps/Registry.hs +++ /dev/null @@ -1,213 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE BangPatterns, OverloadedStrings #-} -module Deps.Registry - ( Registry(..) - , KnownVersions(..) - , read - , fetch - , update - , latest - , getVersions - , getVersions' - ) - where - - -import Prelude hiding (read) -import Control.Monad (liftM2) -import Data.Binary (Binary, get, put) -import qualified Data.List as List -import qualified Data.Map.Strict as Map - -import qualified Deps.Website as Website -import qualified Elm.Package as Pkg -import qualified Elm.Version as V -import qualified File -import qualified Http -import qualified Json.Decode as D -import qualified Parse.Primitives as P -import qualified Reporting.Exit as Exit -import qualified Stuff - - - --- REGISTRY - - -data Registry = - Registry - { _count :: !Int - , _versions :: !(Map.Map Pkg.Name KnownVersions) - } - - -data KnownVersions = - KnownVersions - { _newest :: V.Version - , _previous :: ![V.Version] - } - - - --- READ - - -read :: Stuff.PackageCache -> IO (Maybe Registry) -read cache = - File.readBinary (Stuff.registry cache) - - - --- FETCH - - -fetch :: Http.Manager -> Stuff.PackageCache -> IO (Either Exit.RegistryProblem Registry) -fetch manager cache = - post manager "/all-packages" allPkgsDecoder $ - \versions -> - do let size = Map.foldr' addEntry 0 versions - let registry = Registry size versions - let path = Stuff.registry cache - File.writeBinary path registry - return registry - - -addEntry :: KnownVersions -> Int -> Int -addEntry (KnownVersions _ vs) count = - count + 1 + length vs - - -allPkgsDecoder :: D.Decoder () (Map.Map Pkg.Name KnownVersions) -allPkgsDecoder = - let - keyDecoder = - Pkg.keyDecoder bail - - versionsDecoder = - D.list (D.mapError (\_ -> ()) V.decoder) - - toKnownVersions versions = - case List.sortBy (flip compare) versions of - v:vs -> return (KnownVersions v vs) - [] -> D.failure () - in - D.dict keyDecoder (toKnownVersions =<< versionsDecoder) - - - --- UPDATE - - -update :: Http.Manager -> Stuff.PackageCache -> Registry -> IO (Either Exit.RegistryProblem Registry) -update manager cache oldRegistry@(Registry size packages) = - post manager ("/all-packages/since/" ++ show size) (D.list newPkgDecoder) $ - \news -> - case news of - [] -> - return oldRegistry - - _:_ -> - let - newSize = size + length news - newPkgs = foldr addNew packages news - newRegistry = Registry newSize newPkgs - in - do File.writeBinary (Stuff.registry cache) newRegistry - return newRegistry - - -addNew :: (Pkg.Name, V.Version) -> Map.Map Pkg.Name KnownVersions -> Map.Map Pkg.Name KnownVersions -addNew (name, version) versions = - let - add maybeKnowns = - case maybeKnowns of - Just (KnownVersions v vs) -> - KnownVersions version (v:vs) - - Nothing -> - KnownVersions version [] - in - Map.alter (Just . add) name versions - - - --- NEW PACKAGE DECODER - - -newPkgDecoder :: D.Decoder () (Pkg.Name, V.Version) -newPkgDecoder = - D.customString newPkgParser bail - - -newPkgParser :: P.Parser () (Pkg.Name, V.Version) -newPkgParser = - do pkg <- P.specialize (\_ _ _ -> ()) Pkg.parser - P.word1 0x40 {-@-} bail - vsn <- P.specialize (\_ _ _ -> ()) V.parser - return (pkg, vsn) - - -bail :: row -> col -> () -bail _ _ = - () - - - --- LATEST - - -latest :: Http.Manager -> Stuff.PackageCache -> IO (Either Exit.RegistryProblem Registry) -latest manager cache = - do maybeOldRegistry <- read cache - case maybeOldRegistry of - Just oldRegistry -> - update manager cache oldRegistry - - Nothing -> - fetch manager cache - - - --- GET VERSIONS - - -getVersions :: Pkg.Name -> Registry -> Maybe KnownVersions -getVersions name (Registry _ versions) = - Map.lookup name versions - - -getVersions' :: Pkg.Name -> Registry -> Either [Pkg.Name] KnownVersions -getVersions' name (Registry _ versions) = - case Map.lookup name versions of - Just kvs -> Right kvs - Nothing -> Left $ Pkg.nearbyNames name (Map.keys versions) - - - --- POST - - -post :: Http.Manager -> String -> D.Decoder x a -> (a -> IO b) -> IO (Either Exit.RegistryProblem b) -post manager path decoder callback = - let - url = Website.route path [] - in - Http.post manager url [] Exit.RP_Http $ - \body -> - case D.fromByteString decoder body of - Right a -> Right <$> callback a - Left _ -> return $ Left $ Exit.RP_Data url body - - - --- BINARY - - -instance Binary Registry where - get = liftM2 Registry get get - put (Registry a b) = put a >> put b - - -instance Binary KnownVersions where - get = liftM2 KnownVersions get get - put (KnownVersions a b) = put a >> put b diff --git a/builder/src/Deps/Solver.hs b/builder/src/Deps/Solver.hs deleted file mode 100644 index f38d1bce30..0000000000 --- a/builder/src/Deps/Solver.hs +++ /dev/null @@ -1,444 +0,0 @@ -{-# LANGUAGE OverloadedStrings, Rank2Types #-} -module Deps.Solver - ( Solver - , Result(..) - , Connection(..) - -- - , Details(..) - , verify - -- - , AppSolution(..) - , addToApp - -- - , Env(..) - , initEnv - ) - where - - -import Control.Monad (foldM) -import Control.Concurrent (forkIO, newEmptyMVar, putMVar, readMVar) -import qualified Data.Map as Map -import Data.Map ((!)) -import qualified System.Directory as Dir -import System.FilePath (()) - -import qualified Deps.Registry as Registry -import qualified Deps.Website as Website -import qualified Elm.Constraint as C -import qualified Elm.Package as Pkg -import qualified Elm.Outline as Outline -import qualified Elm.Version as V -import qualified File -import qualified Http -import qualified Json.Decode as D -import qualified Reporting.Exit as Exit -import qualified Stuff - - - --- SOLVER - - -newtype Solver a = - Solver - ( - forall b. - State - -> (State -> a -> (State -> IO b) -> IO b) - -> (State -> IO b) - -> (Exit.Solver -> IO b) - -> IO b - ) - - -data State = - State - { _cache :: Stuff.PackageCache - , _connection :: Connection - , _registry :: Registry.Registry - , _constraints :: Map.Map (Pkg.Name, V.Version) Constraints - } - - -data Constraints = - Constraints - { _elm :: C.Constraint - , _deps :: Map.Map Pkg.Name C.Constraint - } - - -data Connection - = Online Http.Manager - | Offline - - - --- RESULT - - -data Result a - = Ok a - | NoSolution - | NoOfflineSolution - | Err Exit.Solver - - - --- VERIFY -- used by Elm.Details - - -data Details = - Details V.Version (Map.Map Pkg.Name C.Constraint) - - -verify :: Stuff.PackageCache -> Connection -> Registry.Registry -> Map.Map Pkg.Name C.Constraint -> IO (Result (Map.Map Pkg.Name Details)) -verify cache connection registry constraints = - Stuff.withRegistryLock cache $ - case try constraints of - Solver solver -> - solver (State cache connection registry Map.empty) - (\s a _ -> return $ Ok (Map.mapWithKey (addDeps s) a)) - (\_ -> return $ noSolution connection) - (\e -> return $ Err e) - - -addDeps :: State -> Pkg.Name -> V.Version -> Details -addDeps (State _ _ _ constraints) name vsn = - case Map.lookup (name, vsn) constraints of - Just (Constraints _ deps) -> Details vsn deps - Nothing -> error "compiler bug manifesting in Deps.Solver.addDeps" - - -noSolution :: Connection -> Result a -noSolution connection = - case connection of - Online _ -> NoSolution - Offline -> NoOfflineSolution - - - --- ADD TO APP - used in Install - - -data AppSolution = - AppSolution - { _old :: Map.Map Pkg.Name V.Version - , _new :: Map.Map Pkg.Name V.Version - , _app :: Outline.AppOutline - } - - -addToApp :: Stuff.PackageCache -> Connection -> Registry.Registry -> Pkg.Name -> Outline.AppOutline -> IO (Result AppSolution) -addToApp cache connection registry pkg outline@(Outline.AppOutline _ _ direct indirect testDirect testIndirect) = - Stuff.withRegistryLock cache $ - let - allIndirects = Map.union indirect testIndirect - allDirects = Map.union direct testDirect - allDeps = Map.union allDirects allIndirects - - attempt toConstraint deps = - try (Map.insert pkg C.anything (Map.map toConstraint deps)) - in - case - oneOf - ( attempt C.exactly allDeps ) - [ attempt C.exactly allDirects - , attempt C.untilNextMinor allDirects - , attempt C.untilNextMajor allDirects - , attempt (\_ -> C.anything) allDirects - ] - of - Solver solver -> - solver (State cache connection registry Map.empty) - (\s a _ -> return $ Ok (toApp s pkg outline allDeps a)) - (\_ -> return $ noSolution connection) - (\e -> return $ Err e) - - -toApp :: State -> Pkg.Name -> Outline.AppOutline -> Map.Map Pkg.Name V.Version -> Map.Map Pkg.Name V.Version -> AppSolution -toApp (State _ _ _ constraints) pkg (Outline.AppOutline elm srcDirs direct _ testDirect _) old new = - let - d = Map.intersection new (Map.insert pkg V.one direct) - i = Map.difference (getTransitive constraints new (Map.toList d) Map.empty) d - td = Map.intersection new (Map.delete pkg testDirect) - ti = Map.difference new (Map.unions [d,i,td]) - in - AppSolution old new (Outline.AppOutline elm srcDirs d i td ti) - - -getTransitive :: Map.Map (Pkg.Name, V.Version) Constraints -> Map.Map Pkg.Name V.Version -> [(Pkg.Name,V.Version)] -> Map.Map Pkg.Name V.Version -> Map.Map Pkg.Name V.Version -getTransitive constraints solution unvisited visited = - case unvisited of - [] -> - visited - - info@(pkg,vsn) : infos -> - if Map.member pkg visited - then getTransitive constraints solution infos visited - else - let - newDeps = _deps (constraints ! info) - newUnvisited = Map.toList (Map.intersection solution (Map.difference newDeps visited)) - newVisited = Map.insert pkg vsn visited - in - getTransitive constraints solution infos $ - getTransitive constraints solution newUnvisited newVisited - - - --- TRY - - -try :: Map.Map Pkg.Name C.Constraint -> Solver (Map.Map Pkg.Name V.Version) -try constraints = - exploreGoals (Goals constraints Map.empty) - - - --- EXPLORE GOALS - - -data Goals = - Goals - { _pending :: Map.Map Pkg.Name C.Constraint - , _solved :: Map.Map Pkg.Name V.Version - } - - -exploreGoals :: Goals -> Solver (Map.Map Pkg.Name V.Version) -exploreGoals (Goals pending solved) = - case Map.minViewWithKey pending of - Nothing -> - return solved - - Just ((name, constraint), otherPending) -> - do let goals1 = Goals otherPending solved - let addVsn = addVersion goals1 name - (v,vs) <- getRelevantVersions name constraint - goals2 <- oneOf (addVsn v) (map addVsn vs) - exploreGoals goals2 - - -addVersion :: Goals -> Pkg.Name -> V.Version -> Solver Goals -addVersion (Goals pending solved) name version = - do (Constraints elm deps) <- getConstraints name version - if C.goodElm elm - then - do newPending <- foldM (addConstraint solved) pending (Map.toList deps) - return (Goals newPending (Map.insert name version solved)) - else - backtrack - - -addConstraint :: Map.Map Pkg.Name V.Version -> Map.Map Pkg.Name C.Constraint -> (Pkg.Name, C.Constraint) -> Solver (Map.Map Pkg.Name C.Constraint) -addConstraint solved unsolved (name, newConstraint) = - case Map.lookup name solved of - Just version -> - if C.satisfies newConstraint version - then return unsolved - else backtrack - - Nothing -> - case Map.lookup name unsolved of - Nothing -> - return $ Map.insert name newConstraint unsolved - - Just oldConstraint -> - case C.intersect oldConstraint newConstraint of - Nothing -> - backtrack - - Just mergedConstraint -> - if oldConstraint == mergedConstraint - then return unsolved - else return (Map.insert name mergedConstraint unsolved) - - - --- GET RELEVANT VERSIONS - - -getRelevantVersions :: Pkg.Name -> C.Constraint -> Solver (V.Version, [V.Version]) -getRelevantVersions name constraint = - Solver $ \state@(State _ _ registry _) ok back _ -> - case Registry.getVersions name registry of - Just (Registry.KnownVersions newest previous) -> - case filter (C.satisfies constraint) (newest:previous) of - [] -> back state - v:vs -> ok state (v,vs) back - - Nothing -> - back state - - - --- GET CONSTRAINTS - - -getConstraints :: Pkg.Name -> V.Version -> Solver Constraints -getConstraints pkg vsn = - Solver $ \state@(State cache connection registry cDict) ok back err -> - do let key = (pkg, vsn) - case Map.lookup key cDict of - Just cs -> - ok state cs back - - Nothing -> - do let toNewState cs = State cache connection registry (Map.insert key cs cDict) - let home = Stuff.package cache pkg vsn - let path = home "elm.json" - outlineExists <- File.exists path - if outlineExists - then - do bytes <- File.readUtf8 path - case D.fromByteString constraintsDecoder bytes of - Right cs -> - case connection of - Online _ -> - ok (toNewState cs) cs back - - Offline -> - do srcExists <- Dir.doesDirectoryExist (Stuff.package cache pkg vsn "src") - if srcExists - then ok (toNewState cs) cs back - else back state - - Left _ -> - do File.remove path - err (Exit.SolverBadCacheData pkg vsn) - else - case connection of - Offline -> - back state - - Online manager -> - do let url = Website.metadata pkg vsn "elm.json" - result <- Http.get manager url [] id (return . Right) - case result of - Left httpProblem -> - err (Exit.SolverBadHttp pkg vsn httpProblem) - - Right body -> - case D.fromByteString constraintsDecoder body of - Right cs -> - do Dir.createDirectoryIfMissing True home - File.writeUtf8 path body - ok (toNewState cs) cs back - - Left _ -> - err (Exit.SolverBadHttpData pkg vsn url) - - -constraintsDecoder :: D.Decoder () Constraints -constraintsDecoder = - do outline <- D.mapError (const ()) Outline.decoder - case outline of - Outline.Pkg (Outline.PkgOutline _ _ _ _ _ deps _ elmConstraint) -> - return (Constraints elmConstraint deps) - - Outline.App _ -> - D.failure () - - - --- ENVIRONMENT - - -data Env = - Env Stuff.PackageCache Http.Manager Connection Registry.Registry - - -initEnv :: IO (Either Exit.RegistryProblem Env) -initEnv = - do mvar <- newEmptyMVar - _ <- forkIO $ putMVar mvar =<< Http.getManager - cache <- Stuff.getPackageCache - Stuff.withRegistryLock cache $ - do maybeRegistry <- Registry.read cache - manager <- readMVar mvar - - case maybeRegistry of - Nothing -> - do eitherRegistry <- Registry.fetch manager cache - case eitherRegistry of - Right latestRegistry -> - return $ Right $ Env cache manager (Online manager) latestRegistry - - Left problem -> - return $ Left $ problem - - Just cachedRegistry -> - do eitherRegistry <- Registry.update manager cache cachedRegistry - case eitherRegistry of - Right latestRegistry -> - return $ Right $ Env cache manager (Online manager) latestRegistry - - Left _ -> - return $ Right $ Env cache manager Offline cachedRegistry - - - --- INSTANCES - - -instance Functor Solver where - fmap func (Solver solver) = - Solver $ \state ok back err -> - let - okA stateA arg backA = ok stateA (func arg) backA - in - solver state okA back err - - -instance Applicative Solver where - pure a = - Solver $ \state ok back _ -> ok state a back - - (<*>) (Solver solverFunc) (Solver solverArg) = - Solver $ \state ok back err -> - let - okF stateF func backF = - let - okA stateA arg backA = ok stateA (func arg) backA - in - solverArg stateF okA backF err - in - solverFunc state okF back err - - -instance Monad Solver where - return a = - Solver $ \state ok back _ -> ok state a back - - (>>=) (Solver solverA) callback = - Solver $ \state ok back err -> - let - okA stateA a backA = - case callback a of - Solver solverB -> solverB stateA ok backA err - in - solverA state okA back err - - -oneOf :: Solver a -> [Solver a] -> Solver a -oneOf solver@(Solver solverHead) solvers = - case solvers of - [] -> - solver - - s:ss -> - Solver $ \state0 ok back err -> - let - tryTail state1 = - let - (Solver solverTail) = oneOf s ss - in - solverTail state1 ok back err - in - solverHead state0 ok tryTail err - - -backtrack :: Solver a -backtrack = - Solver $ \state _ back _ -> back state diff --git a/builder/src/Deps/Website.hs b/builder/src/Deps/Website.hs deleted file mode 100644 index ab6a90ecea..0000000000 --- a/builder/src/Deps/Website.hs +++ /dev/null @@ -1,26 +0,0 @@ -module Deps.Website - ( domain - , route - , metadata - ) - where - - -import qualified Elm.Package as Pkg -import qualified Elm.Version as V -import qualified Http - - -domain :: String -domain = - "https://package.elm-lang.org" - - -route :: String -> [(String,String)] -> String -route path params = - Http.toUrl (domain ++ path) params - - -metadata :: Pkg.Name -> V.Version -> String -> String -metadata name version file = - domain ++ "/packages/" ++ Pkg.toUrl name ++ "/" ++ V.toChars version ++ "/" ++ file diff --git a/builder/src/Elm/Details.hs b/builder/src/Elm/Details.hs deleted file mode 100644 index 42684b6556..0000000000 --- a/builder/src/Elm/Details.hs +++ /dev/null @@ -1,833 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE BangPatterns, OverloadedStrings #-} -module Elm.Details - ( Details(..) - , BuildID - , ValidOutline(..) - , Local(..) - , Foreign(..) - , load - , loadObjects - , loadInterfaces - , verifyInstall - ) - where - - -import Control.Concurrent (forkIO) -import Control.Concurrent.MVar (MVar, newEmptyMVar, newMVar, putMVar, readMVar, takeMVar) -import Control.Monad (liftM, liftM2, liftM3) -import Data.Binary (Binary, get, put, getWord8, putWord8) -import qualified Data.Either as Either -import qualified Data.Map as Map -import qualified Data.Map.Utils as Map -import qualified Data.Map.Merge.Strict as Map -import qualified Data.Maybe as Maybe -import qualified Data.Name as Name -import qualified Data.NonEmptyList as NE -import qualified Data.OneOrMore as OneOrMore -import qualified Data.Set as Set -import qualified Data.Utf8 as Utf8 -import Data.Word (Word64) -import qualified System.Directory as Dir -import System.FilePath ((), (<.>)) - -import qualified AST.Canonical as Can -import qualified AST.Source as Src -import qualified AST.Optimized as Opt -import qualified BackgroundWriter as BW -import qualified Compile -import qualified Deps.Registry as Registry -import qualified Deps.Solver as Solver -import qualified Deps.Website as Website -import qualified Elm.Constraint as Con -import qualified Elm.Docs as Docs -import qualified Elm.Interface as I -import qualified Elm.Kernel as Kernel -import qualified Elm.ModuleName as ModuleName -import qualified Elm.Outline as Outline -import qualified Elm.Package as Pkg -import qualified Elm.Version as V -import qualified File -import qualified Http -import qualified Json.Decode as D -import qualified Json.Encode as E -import qualified Parse.Module as Parse -import qualified Reporting -import qualified Reporting.Annotation as A -import qualified Reporting.Exit as Exit -import qualified Reporting.Task as Task -import qualified Stuff - - - --- DETAILS - - -data Details = - Details - { _outlineTime :: File.Time - , _outline :: ValidOutline - , _buildID :: BuildID - , _locals :: Map.Map ModuleName.Raw Local - , _foreigns :: Map.Map ModuleName.Raw Foreign - , _extras :: Extras - } - - -type BuildID = Word64 - - -data ValidOutline - = ValidApp (NE.List Outline.SrcDir) - | ValidPkg Pkg.Name [ModuleName.Raw] (Map.Map Pkg.Name V.Version {- for docs in reactor -}) - - --- NOTE: we need two ways to detect if a file must be recompiled: --- --- (1) _time is the modification time from the last time we compiled the file. --- By checking EQUALITY with the current modification time, we can detect file --- saves and `git checkout` of previous versions. Both need a recompile. --- --- (2) _lastChange is the BuildID from the last time a new interface file was --- generated, and _lastCompile is the BuildID from the last time the file was --- compiled. These may be different if a file is recompiled but the interface --- stayed the same. When the _lastCompile is LESS THAN the _lastChange of any --- imports, we need to recompile. This can happen when a project has multiple --- entrypoints and some modules are compiled less often than their imports. --- -data Local = - Local - { _path :: FilePath - , _time :: File.Time - , _deps :: [ModuleName.Raw] - , _main :: Bool - , _lastChange :: BuildID - , _lastCompile :: BuildID - } - - -data Foreign = - Foreign Pkg.Name [Pkg.Name] - - -data Extras - = ArtifactsCached - | ArtifactsFresh Interfaces Opt.GlobalGraph - - -type Interfaces = - Map.Map ModuleName.Canonical I.DependencyInterface - - - --- LOAD ARTIFACTS - - -loadObjects :: FilePath -> Details -> IO (MVar (Maybe Opt.GlobalGraph)) -loadObjects root (Details _ _ _ _ _ extras) = - case extras of - ArtifactsFresh _ o -> newMVar (Just o) - ArtifactsCached -> fork (File.readBinary (Stuff.objects root)) - - -loadInterfaces :: FilePath -> Details -> IO (MVar (Maybe Interfaces)) -loadInterfaces root (Details _ _ _ _ _ extras) = - case extras of - ArtifactsFresh i _ -> newMVar (Just i) - ArtifactsCached -> fork (File.readBinary (Stuff.interfaces root)) - - - --- VERIFY INSTALL -- used by Install - - -verifyInstall :: BW.Scope -> FilePath -> Solver.Env -> Outline.Outline -> IO (Either Exit.Details ()) -verifyInstall scope root (Solver.Env cache manager connection registry) outline = - do time <- File.getTime (root "elm.json") - let key = Reporting.ignorer - let env = Env key scope root cache manager connection registry - case outline of - Outline.Pkg pkg -> Task.run (verifyPkg env time pkg >> return ()) - Outline.App app -> Task.run (verifyApp env time app >> return ()) - - - --- LOAD -- used by Make, Repl, Reactor - - -load :: Reporting.Style -> BW.Scope -> FilePath -> IO (Either Exit.Details Details) -load style scope root = - do newTime <- File.getTime (root "elm.json") - maybeDetails <- File.readBinary (Stuff.details root) - case maybeDetails of - Nothing -> - generate style scope root newTime - - Just details@(Details oldTime _ buildID _ _ _) -> - if oldTime == newTime - then return (Right details { _buildID = buildID + 1 }) - else generate style scope root newTime - - - --- GENERATE - - -generate :: Reporting.Style -> BW.Scope -> FilePath -> File.Time -> IO (Either Exit.Details Details) -generate style scope root time = - Reporting.trackDetails style $ \key -> - do result <- initEnv key scope root - case result of - Left exit -> - return (Left exit) - - Right (env, outline) -> - case outline of - Outline.Pkg pkg -> Task.run (verifyPkg env time pkg) - Outline.App app -> Task.run (verifyApp env time app) - - - --- ENV - - -data Env = - Env - { _key :: Reporting.DKey - , _scope :: BW.Scope - , _root :: FilePath - , _cache :: Stuff.PackageCache - , _manager :: Http.Manager - , _connection :: Solver.Connection - , _registry :: Registry.Registry - } - - -initEnv :: Reporting.DKey -> BW.Scope -> FilePath -> IO (Either Exit.Details (Env, Outline.Outline)) -initEnv key scope root = - do mvar <- fork Solver.initEnv - eitherOutline <- Outline.read root - case eitherOutline of - Left problem -> - return $ Left $ Exit.DetailsBadOutline problem - - Right outline -> - do maybeEnv <- readMVar mvar - case maybeEnv of - Left problem -> - return $ Left $ Exit.DetailsCannotGetRegistry problem - - Right (Solver.Env cache manager connection registry) -> - return $ Right (Env key scope root cache manager connection registry, outline) - - - --- VERIFY PROJECT - - -type Task a = Task.Task Exit.Details a - - -verifyPkg :: Env -> File.Time -> Outline.PkgOutline -> Task Details -verifyPkg env time (Outline.PkgOutline pkg _ _ _ exposed direct testDirect elm) = - if Con.goodElm elm - then - do solution <- verifyConstraints env =<< union noDups direct testDirect - let exposedList = Outline.flattenExposed exposed - let exactDeps = Map.map (\(Solver.Details v _) -> v) solution -- for pkg docs in reactor - verifyDependencies env time (ValidPkg pkg exposedList exactDeps) solution direct - else - Task.throw $ Exit.DetailsBadElmInPkg elm - - -verifyApp :: Env -> File.Time -> Outline.AppOutline -> Task Details -verifyApp env time outline@(Outline.AppOutline elmVersion srcDirs direct _ _ _) = - if elmVersion == V.compiler - then - do stated <- checkAppDeps outline - actual <- verifyConstraints env (Map.map Con.exactly stated) - if Map.size stated == Map.size actual - then verifyDependencies env time (ValidApp srcDirs) actual direct - else Task.throw $ Exit.DetailsHandEditedDependencies - else - Task.throw $ Exit.DetailsBadElmInAppOutline elmVersion - - -checkAppDeps :: Outline.AppOutline -> Task (Map.Map Pkg.Name V.Version) -checkAppDeps (Outline.AppOutline _ _ direct indirect testDirect testIndirect) = - do x <- union allowEqualDups indirect testDirect - y <- union noDups direct testIndirect - union noDups x y - - - --- VERIFY CONSTRAINTS - - -verifyConstraints :: Env -> Map.Map Pkg.Name Con.Constraint -> Task (Map.Map Pkg.Name Solver.Details) -verifyConstraints (Env _ _ _ cache _ connection registry) constraints = - do result <- Task.io $ Solver.verify cache connection registry constraints - case result of - Solver.Ok details -> return details - Solver.NoSolution -> Task.throw $ Exit.DetailsNoSolution - Solver.NoOfflineSolution -> Task.throw $ Exit.DetailsNoOfflineSolution - Solver.Err exit -> Task.throw $ Exit.DetailsSolverProblem exit - - - --- UNION - - -union :: (Ord k) => (k -> v -> v -> Task v) -> Map.Map k v -> Map.Map k v -> Task (Map.Map k v) -union tieBreaker deps1 deps2 = - Map.mergeA Map.preserveMissing Map.preserveMissing (Map.zipWithAMatched tieBreaker) deps1 deps2 - - -noDups :: k -> v -> v -> Task v -noDups _ _ _ = - Task.throw Exit.DetailsHandEditedDependencies - - -allowEqualDups :: (Eq v) => k -> v -> v -> Task v -allowEqualDups _ v1 v2 = - if v1 == v2 - then return v1 - else Task.throw Exit.DetailsHandEditedDependencies - - - --- FORK - - -fork :: IO a -> IO (MVar a) -fork work = - do mvar <- newEmptyMVar - _ <- forkIO $ putMVar mvar =<< work - return mvar - - - --- VERIFY DEPENDENCIES - - -verifyDependencies :: Env -> File.Time -> ValidOutline -> Map.Map Pkg.Name Solver.Details -> Map.Map Pkg.Name a -> Task Details -verifyDependencies env@(Env key scope root cache _ _ _) time outline solution directDeps = - Task.eio id $ - do Reporting.report key (Reporting.DStart (Map.size solution)) - mvar <- newEmptyMVar - mvars <- Stuff.withRegistryLock cache $ - Map.traverseWithKey (\k v -> fork (verifyDep env mvar solution k v)) solution - putMVar mvar mvars - deps <- traverse readMVar mvars - case sequence deps of - Left _ -> - do home <- Stuff.getElmHome - return $ Left $ Exit.DetailsBadDeps home $ - Maybe.catMaybes $ Either.lefts $ Map.elems deps - - Right artifacts -> - let - objs = Map.foldr addObjects Opt.empty artifacts - ifaces = Map.foldrWithKey (addInterfaces directDeps) Map.empty artifacts - foreigns = Map.map (OneOrMore.destruct Foreign) $ Map.foldrWithKey gatherForeigns Map.empty $ Map.intersection artifacts directDeps - details = Details time outline 0 Map.empty foreigns (ArtifactsFresh ifaces objs) - in - do BW.writeBinary scope (Stuff.objects root) objs - BW.writeBinary scope (Stuff.interfaces root) ifaces - BW.writeBinary scope (Stuff.details root) details - return (Right details) - - -addObjects :: Artifacts -> Opt.GlobalGraph -> Opt.GlobalGraph -addObjects (Artifacts _ objs) graph = - Opt.addGlobalGraph objs graph - - -addInterfaces :: Map.Map Pkg.Name a -> Pkg.Name -> Artifacts -> Interfaces -> Interfaces -addInterfaces directDeps pkg (Artifacts ifaces _) dependencyInterfaces = - Map.union dependencyInterfaces $ Map.mapKeysMonotonic (ModuleName.Canonical pkg) $ - if Map.member pkg directDeps - then ifaces - else Map.map I.privatize ifaces - - -gatherForeigns :: Pkg.Name -> Artifacts -> Map.Map ModuleName.Raw (OneOrMore.OneOrMore Pkg.Name) -> Map.Map ModuleName.Raw (OneOrMore.OneOrMore Pkg.Name) -gatherForeigns pkg (Artifacts ifaces _) foreigns = - let - isPublic di = - case di of - I.Public _ -> Just (OneOrMore.one pkg) - I.Private _ _ _ -> Nothing - in - Map.unionWith OneOrMore.more foreigns (Map.mapMaybe isPublic ifaces) - - - --- VERIFY DEPENDENCY - - -data Artifacts = - Artifacts - { _ifaces :: Map.Map ModuleName.Raw I.DependencyInterface - , _objects :: Opt.GlobalGraph - } - - -type Dep = - Either (Maybe Exit.DetailsBadDep) Artifacts - - -verifyDep :: Env -> MVar (Map.Map Pkg.Name (MVar Dep)) -> Map.Map Pkg.Name Solver.Details -> Pkg.Name -> Solver.Details -> IO Dep -verifyDep (Env key _ _ cache manager _ _) depsMVar solution pkg details@(Solver.Details vsn directDeps) = - do let fingerprint = Map.intersectionWith (\(Solver.Details v _) _ -> v) solution directDeps - exists <- Dir.doesDirectoryExist (Stuff.package cache pkg vsn "src") - if exists - then - do Reporting.report key Reporting.DCached - maybeCache <- File.readBinary (Stuff.package cache pkg vsn "artifacts.dat") - case maybeCache of - Nothing -> - build key cache depsMVar pkg details fingerprint Set.empty - - Just (ArtifactCache fingerprints artifacts) -> - if Set.member fingerprint fingerprints - then Reporting.report key Reporting.DBuilt >> return (Right artifacts) - else build key cache depsMVar pkg details fingerprint fingerprints - else - do Reporting.report key Reporting.DRequested - result <- downloadPackage cache manager pkg vsn - case result of - Left problem -> - do Reporting.report key (Reporting.DFailed pkg vsn) - return $ Left $ Just $ Exit.BD_BadDownload pkg vsn problem - - Right () -> - do Reporting.report key (Reporting.DReceived pkg vsn) - build key cache depsMVar pkg details fingerprint Set.empty - - - --- ARTIFACT CACHE - - -data ArtifactCache = - ArtifactCache - { _fingerprints :: Set.Set Fingerprint - , _artifacts :: Artifacts - } - - -type Fingerprint = - Map.Map Pkg.Name V.Version - - - --- BUILD - - -build :: Reporting.DKey -> Stuff.PackageCache -> MVar (Map.Map Pkg.Name (MVar Dep)) -> Pkg.Name -> Solver.Details -> Fingerprint -> Set.Set Fingerprint -> IO Dep -build key cache depsMVar pkg (Solver.Details vsn _) f fs = - do eitherOutline <- Outline.read (Stuff.package cache pkg vsn) - case eitherOutline of - Left _ -> - do Reporting.report key Reporting.DBroken - return $ Left $ Just $ Exit.BD_BadBuild pkg vsn f - - Right (Outline.App _) -> - do Reporting.report key Reporting.DBroken - return $ Left $ Just $ Exit.BD_BadBuild pkg vsn f - - Right (Outline.Pkg (Outline.PkgOutline _ _ _ _ exposed deps _ _)) -> - do allDeps <- readMVar depsMVar - directDeps <- traverse readMVar (Map.intersection allDeps deps) - case sequence directDeps of - Left _ -> - do Reporting.report key Reporting.DBroken - return $ Left $ Nothing - - Right directArtifacts -> - do let src = Stuff.package cache pkg vsn "src" - let foreignDeps = gatherForeignInterfaces directArtifacts - let exposedDict = Map.fromKeys (\_ -> ()) (Outline.flattenExposed exposed) - docsStatus <- getDocsStatus cache pkg vsn - mvar <- newEmptyMVar - mvars <- Map.traverseWithKey (const . fork . crawlModule foreignDeps mvar pkg src docsStatus) exposedDict - putMVar mvar mvars - mapM_ readMVar mvars - maybeStatuses <- traverse readMVar =<< readMVar mvar - case sequence maybeStatuses of - Nothing -> - do Reporting.report key Reporting.DBroken - return $ Left $ Just $ Exit.BD_BadBuild pkg vsn f - - Just statuses -> - do rmvar <- newEmptyMVar - rmvars <- traverse (fork . compile pkg rmvar) statuses - putMVar rmvar rmvars - maybeResults <- traverse readMVar rmvars - case sequence maybeResults of - Nothing -> - do Reporting.report key Reporting.DBroken - return $ Left $ Just $ Exit.BD_BadBuild pkg vsn f - - Just results -> - let - path = Stuff.package cache pkg vsn "artifacts.dat" - ifaces = gatherInterfaces exposedDict results - objects = gatherObjects results - artifacts = Artifacts ifaces objects - fingerprints = Set.insert f fs - in - do writeDocs cache pkg vsn docsStatus results - File.writeBinary path (ArtifactCache fingerprints artifacts) - Reporting.report key Reporting.DBuilt - return (Right artifacts) - - - --- GATHER - - -gatherObjects :: Map.Map ModuleName.Raw Result -> Opt.GlobalGraph -gatherObjects results = - Map.foldrWithKey addLocalGraph Opt.empty results - - -addLocalGraph :: ModuleName.Raw -> Result -> Opt.GlobalGraph -> Opt.GlobalGraph -addLocalGraph name status graph = - case status of - RLocal _ objs _ -> Opt.addLocalGraph objs graph - RForeign _ -> graph - RKernelLocal cs -> Opt.addKernel (Name.getKernel name) cs graph - RKernelForeign -> graph - - -gatherInterfaces :: Map.Map ModuleName.Raw () -> Map.Map ModuleName.Raw Result -> Map.Map ModuleName.Raw I.DependencyInterface -gatherInterfaces exposed artifacts = - let - onLeft = Map.mapMissing (error "compiler bug manifesting in Elm.Details.gatherInterfaces") - onRight = Map.mapMaybeMissing (\_ iface -> toLocalInterface I.private iface) - onBoth = Map.zipWithMaybeMatched (\_ () iface -> toLocalInterface I.public iface) - in - Map.merge onLeft onRight onBoth exposed artifacts - - -toLocalInterface :: (I.Interface -> a) -> Result -> Maybe a -toLocalInterface func result = - case result of - RLocal iface _ _ -> Just (func iface) - RForeign _ -> Nothing - RKernelLocal _ -> Nothing - RKernelForeign -> Nothing - - - --- GATHER FOREIGN INTERFACES - - -data ForeignInterface - = ForeignAmbiguous - | ForeignSpecific I.Interface - - -gatherForeignInterfaces :: Map.Map Pkg.Name Artifacts -> Map.Map ModuleName.Raw ForeignInterface -gatherForeignInterfaces directArtifacts = - Map.map (OneOrMore.destruct finalize) $ - Map.foldrWithKey gather Map.empty directArtifacts - where - finalize :: I.Interface -> [I.Interface] -> ForeignInterface - finalize i is = - case is of - [] -> ForeignSpecific i - _:_ -> ForeignAmbiguous - - gather :: Pkg.Name -> Artifacts -> Map.Map ModuleName.Raw (OneOrMore.OneOrMore I.Interface) -> Map.Map ModuleName.Raw (OneOrMore.OneOrMore I.Interface) - gather _ (Artifacts ifaces _) buckets = - Map.unionWith OneOrMore.more buckets (Map.mapMaybe isPublic ifaces) - - isPublic :: I.DependencyInterface -> Maybe (OneOrMore.OneOrMore I.Interface) - isPublic di = - case di of - I.Public iface -> Just (OneOrMore.one iface) - I.Private _ _ _ -> Nothing - - - --- CRAWL - - -type StatusDict = - Map.Map ModuleName.Raw (MVar (Maybe Status)) - - -data Status - = SLocal DocsStatus (Map.Map ModuleName.Raw ()) Src.Module - | SForeign I.Interface - | SKernelLocal [Kernel.Chunk] - | SKernelForeign - - -crawlModule :: Map.Map ModuleName.Raw ForeignInterface -> MVar StatusDict -> Pkg.Name -> FilePath -> DocsStatus -> ModuleName.Raw -> IO (Maybe Status) -crawlModule foreignDeps mvar pkg src docsStatus name = - do let path = src ModuleName.toFilePath name <.> "elm" - exists <- File.exists path - case Map.lookup name foreignDeps of - Just ForeignAmbiguous -> - return Nothing - - Just (ForeignSpecific iface) -> - if exists - then return Nothing - else return (Just (SForeign iface)) - - Nothing -> - if exists then - crawlFile foreignDeps mvar pkg src docsStatus name path - - else if Pkg.isKernel pkg && Name.isKernel name then - crawlKernel foreignDeps mvar pkg src name - - else - return Nothing - - -crawlFile :: Map.Map ModuleName.Raw ForeignInterface -> MVar StatusDict -> Pkg.Name -> FilePath -> DocsStatus -> ModuleName.Raw -> FilePath -> IO (Maybe Status) -crawlFile foreignDeps mvar pkg src docsStatus expectedName path = - do bytes <- File.readUtf8 path - case Parse.fromByteString (Parse.Package pkg) bytes of - Right modul@(Src.Module (Just (A.At _ actualName)) _ _ imports _ _ _ _ _) | expectedName == actualName -> - do deps <- crawlImports foreignDeps mvar pkg src imports - return (Just (SLocal docsStatus deps modul)) - - _ -> - return Nothing - - -crawlImports :: Map.Map ModuleName.Raw ForeignInterface -> MVar StatusDict -> Pkg.Name -> FilePath -> [Src.Import] -> IO (Map.Map ModuleName.Raw ()) -crawlImports foreignDeps mvar pkg src imports = - do statusDict <- takeMVar mvar - let deps = Map.fromList (map (\i -> (Src.getImportName i, ())) imports) - let news = Map.difference deps statusDict - mvars <- Map.traverseWithKey (const . fork . crawlModule foreignDeps mvar pkg src DocsNotNeeded) news - putMVar mvar (Map.union mvars statusDict) - mapM_ readMVar mvars - return deps - - -crawlKernel :: Map.Map ModuleName.Raw ForeignInterface -> MVar StatusDict -> Pkg.Name -> FilePath -> ModuleName.Raw -> IO (Maybe Status) -crawlKernel foreignDeps mvar pkg src name = - do let path = src ModuleName.toFilePath name <.> "js" - exists <- File.exists path - if exists - then - do bytes <- File.readUtf8 path - case Kernel.fromByteString pkg (Map.mapMaybe getDepHome foreignDeps) bytes of - Nothing -> - return Nothing - - Just (Kernel.Content imports chunks) -> - do _ <- crawlImports foreignDeps mvar pkg src imports - return (Just (SKernelLocal chunks)) - else - return (Just SKernelForeign) - - -getDepHome :: ForeignInterface -> Maybe Pkg.Name -getDepHome fi = - case fi of - ForeignSpecific (I.Interface pkg _ _ _ _) -> Just pkg - ForeignAmbiguous -> Nothing - - - --- COMPILE - - -data Result - = RLocal !I.Interface !Opt.LocalGraph (Maybe Docs.Module) - | RForeign I.Interface - | RKernelLocal [Kernel.Chunk] - | RKernelForeign - - -compile :: Pkg.Name -> MVar (Map.Map ModuleName.Raw (MVar (Maybe Result))) -> Status -> IO (Maybe Result) -compile pkg mvar status = - case status of - SLocal docsStatus deps modul -> - do resultsDict <- readMVar mvar - maybeResults <- traverse readMVar (Map.intersection resultsDict deps) - case sequence maybeResults of - Nothing -> - return Nothing - - Just results -> - case Compile.compile pkg (Map.mapMaybe getInterface results) modul of - Left _ -> - return Nothing - - Right (Compile.Artifacts canonical annotations objects) -> - let - ifaces = I.fromModule pkg canonical annotations - docs = makeDocs docsStatus canonical - in - return (Just (RLocal ifaces objects docs)) - - SForeign iface -> - return (Just (RForeign iface)) - - SKernelLocal chunks -> - return (Just (RKernelLocal chunks)) - - SKernelForeign -> - return (Just RKernelForeign) - - -getInterface :: Result -> Maybe I.Interface -getInterface result = - case result of - RLocal iface _ _ -> Just iface - RForeign iface -> Just iface - RKernelLocal _ -> Nothing - RKernelForeign -> Nothing - - - --- MAKE DOCS - - -data DocsStatus - = DocsNeeded - | DocsNotNeeded - - -getDocsStatus :: Stuff.PackageCache -> Pkg.Name -> V.Version -> IO DocsStatus -getDocsStatus cache pkg vsn = - do exists <- File.exists (Stuff.package cache pkg vsn "docs.json") - if exists - then return DocsNotNeeded - else return DocsNeeded - - -makeDocs :: DocsStatus -> Can.Module -> Maybe Docs.Module -makeDocs status modul = - case status of - DocsNeeded -> - case Docs.fromModule modul of - Right docs -> Just docs - Left _ -> Nothing - - DocsNotNeeded -> - Nothing - - -writeDocs :: Stuff.PackageCache -> Pkg.Name -> V.Version -> DocsStatus -> Map.Map ModuleName.Raw Result -> IO () -writeDocs cache pkg vsn status results = - case status of - DocsNeeded -> - E.writeUgly (Stuff.package cache pkg vsn "docs.json") $ - Docs.encode $ Map.mapMaybe toDocs results - - DocsNotNeeded -> - return () - - -toDocs :: Result -> Maybe Docs.Module -toDocs result = - case result of - RLocal _ _ docs -> docs - RForeign _ -> Nothing - RKernelLocal _ -> Nothing - RKernelForeign -> Nothing - - - --- DOWNLOAD PACKAGE - - -downloadPackage :: Stuff.PackageCache -> Http.Manager -> Pkg.Name -> V.Version -> IO (Either Exit.PackageProblem ()) -downloadPackage cache manager pkg vsn = - let - url = Website.metadata pkg vsn "endpoint.json" - in - do eitherByteString <- - Http.get manager url [] id (return . Right) - - case eitherByteString of - Left err -> - return $ Left $ Exit.PP_BadEndpointRequest err - - Right byteString -> - case D.fromByteString endpointDecoder byteString of - Left _ -> - return $ Left $ Exit.PP_BadEndpointContent url - - Right (endpoint, expectedHash) -> - Http.getArchive manager endpoint Exit.PP_BadArchiveRequest (Exit.PP_BadArchiveContent endpoint) $ - \(sha, archive) -> - if expectedHash == Http.shaToChars sha - then Right <$> File.writePackage (Stuff.package cache pkg vsn) archive - else return $ Left $ Exit.PP_BadArchiveHash endpoint expectedHash (Http.shaToChars sha) - - -endpointDecoder :: D.Decoder e (String, String) -endpointDecoder = - do url <- D.field "url" D.string - hash <- D.field "hash" D.string - return (Utf8.toChars url, Utf8.toChars hash) - - - --- BINARY - - -instance Binary Details where - put (Details a b c d e _) = put a >> put b >> put c >> put d >> put e - get = - do a <- get - b <- get - c <- get - d <- get - e <- get - return (Details a b c d e ArtifactsCached) - - -instance Binary ValidOutline where - put outline = - case outline of - ValidApp a -> putWord8 0 >> put a - ValidPkg a b c -> putWord8 1 >> put a >> put b >> put c - - get = - do n <- getWord8 - case n of - 0 -> liftM ValidApp get - 1 -> liftM3 ValidPkg get get get - _ -> fail "binary encoding of ValidOutline was corrupted" - - -instance Binary Local where - put (Local a b c d e f) = put a >> put b >> put c >> put d >> put e >> put f - get = - do a <- get - b <- get - c <- get - d <- get - e <- get - f <- get - return (Local a b c d e f) - - -instance Binary Foreign where - get = liftM2 Foreign get get - put (Foreign a b) = put a >> put b - - -instance Binary Artifacts where - get = liftM2 Artifacts get get - put (Artifacts a b) = put a >> put b - - -instance Binary ArtifactCache where - get = liftM2 ArtifactCache get get - put (ArtifactCache a b) = put a >> put b diff --git a/builder/src/Elm/Outline.hs b/builder/src/Elm/Outline.hs deleted file mode 100644 index 57028642b3..0000000000 --- a/builder/src/Elm/Outline.hs +++ /dev/null @@ -1,407 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE MultiWayIf, OverloadedStrings #-} -module Elm.Outline - ( Outline(..) - , AppOutline(..) - , PkgOutline(..) - , Exposed(..) - , SrcDir(..) - , read - , write - , encode - , decoder - , defaultSummary - , flattenExposed - ) - where - - -import Prelude hiding (read) -import Control.Monad (filterM, liftM) -import Data.Binary (Binary, get, put, getWord8, putWord8) -import qualified Data.Map as Map -import qualified Data.NonEmptyList as NE -import qualified Data.OneOrMore as OneOrMore -import Foreign.Ptr (minusPtr) -import qualified System.Directory as Dir -import qualified System.FilePath as FP -import System.FilePath (()) - -import qualified Elm.Constraint as Con -import qualified Elm.Licenses as Licenses -import qualified Elm.ModuleName as ModuleName -import qualified Elm.Package as Pkg -import qualified Elm.Version as V -import qualified File -import qualified Json.Decode as D -import qualified Json.Encode as E -import Json.Encode ((==>)) -import qualified Json.String as Json -import qualified Parse.Primitives as P -import qualified Reporting.Exit as Exit - - - --- OUTLINE - - -data Outline - = App AppOutline - | Pkg PkgOutline - - -data AppOutline = - AppOutline - { _app_elm_version :: V.Version - , _app_source_dirs :: NE.List SrcDir - , _app_deps_direct :: Map.Map Pkg.Name V.Version - , _app_deps_indirect :: Map.Map Pkg.Name V.Version - , _app_test_direct :: Map.Map Pkg.Name V.Version - , _app_test_indirect :: Map.Map Pkg.Name V.Version - } - - -data PkgOutline = - PkgOutline - { _pkg_name :: Pkg.Name - , _pkg_summary :: Json.String - , _pkg_license :: Licenses.License - , _pkg_version :: V.Version - , _pkg_exposed :: Exposed - , _pkg_deps :: Map.Map Pkg.Name Con.Constraint - , _pkg_test_deps :: Map.Map Pkg.Name Con.Constraint - , _pkg_elm_version :: Con.Constraint - } - - -data Exposed - = ExposedList [ModuleName.Raw] - | ExposedDict [(Json.String, [ModuleName.Raw])] - - -data SrcDir - = AbsoluteSrcDir FilePath - | RelativeSrcDir FilePath - - - --- DEFAULTS - - -defaultSummary :: Json.String -defaultSummary = - Json.fromChars "helpful summary of your project, less than 80 characters" - - - --- HELPERS - - -flattenExposed :: Exposed -> [ModuleName.Raw] -flattenExposed exposed = - case exposed of - ExposedList names -> - names - - ExposedDict sections -> - concatMap snd sections - - - --- WRITE - - -write :: FilePath -> Outline -> IO () -write root outline = - E.write (root "elm.json") (encode outline) - - - --- JSON ENCODE - - -encode :: Outline -> E.Value -encode outline = - case outline of - App (AppOutline elm srcDirs depsDirect depsTrans testDirect testTrans) -> - E.object - [ "type" ==> E.chars "application" - , "source-directories" ==> E.list encodeSrcDir (NE.toList srcDirs) - , "elm-version" ==> V.encode elm - , "dependencies" ==> - E.object - [ "direct" ==> encodeDeps V.encode depsDirect - , "indirect" ==> encodeDeps V.encode depsTrans - ] - , "test-dependencies" ==> - E.object - [ "direct" ==> encodeDeps V.encode testDirect - , "indirect" ==> encodeDeps V.encode testTrans - ] - ] - - Pkg (PkgOutline name summary license version exposed deps tests elm) -> - E.object - [ "type" ==> E.string (Json.fromChars "package") - , "name" ==> Pkg.encode name - , "summary" ==> E.string summary - , "license" ==> Licenses.encode license - , "version" ==> V.encode version - , "exposed-modules" ==> encodeExposed exposed - , "elm-version" ==> Con.encode elm - , "dependencies" ==> encodeDeps Con.encode deps - , "test-dependencies" ==> encodeDeps Con.encode tests - ] - - -encodeExposed :: Exposed -> E.Value -encodeExposed exposed = - case exposed of - ExposedList modules -> - E.list encodeModule modules - - ExposedDict chunks -> - E.object (map (fmap (E.list encodeModule)) chunks) - - -encodeModule :: ModuleName.Raw -> E.Value -encodeModule name = - E.name name - - -encodeDeps :: (a -> E.Value) -> Map.Map Pkg.Name a -> E.Value -encodeDeps encodeValue deps = - E.dict Pkg.toJsonString encodeValue deps - - -encodeSrcDir :: SrcDir -> E.Value -encodeSrcDir srcDir = - case srcDir of - AbsoluteSrcDir dir -> E.chars dir - RelativeSrcDir dir -> E.chars dir - - - --- PARSE AND VERIFY - - -read :: FilePath -> IO (Either Exit.Outline Outline) -read root = - do bytes <- File.readUtf8 (root "elm.json") - case D.fromByteString decoder bytes of - Left err -> - return $ Left (Exit.OutlineHasBadStructure err) - - Right outline -> - case outline of - Pkg (PkgOutline pkg _ _ _ _ deps _ _) -> - return $ - if Map.notMember Pkg.core deps && pkg /= Pkg.core - then Left Exit.OutlineNoPkgCore - else Right outline - - App (AppOutline _ srcDirs direct indirect _ _) - | Map.notMember Pkg.core direct -> - return $ Left Exit.OutlineNoAppCore - - | Map.notMember Pkg.json direct && Map.notMember Pkg.json indirect -> - return $ Left Exit.OutlineNoAppJson - - | otherwise -> - do badDirs <- filterM (isSrcDirMissing root) (NE.toList srcDirs) - case map toGiven badDirs of - d:ds -> - return $ Left (Exit.OutlineHasMissingSrcDirs d ds) - - [] -> - do maybeDups <- detectDuplicates root (NE.toList srcDirs) - case maybeDups of - Nothing -> - return $ Right outline - - Just (canonicalDir, (dir1,dir2)) -> - return $ Left (Exit.OutlineHasDuplicateSrcDirs canonicalDir dir1 dir2) - - -isSrcDirMissing :: FilePath -> SrcDir -> IO Bool -isSrcDirMissing root srcDir = - not <$> Dir.doesDirectoryExist (toAbsolute root srcDir) - - -toGiven :: SrcDir -> FilePath -toGiven srcDir = - case srcDir of - AbsoluteSrcDir dir -> dir - RelativeSrcDir dir -> dir - - -toAbsolute :: FilePath -> SrcDir -> FilePath -toAbsolute root srcDir = - case srcDir of - AbsoluteSrcDir dir -> dir - RelativeSrcDir dir -> root dir - - -detectDuplicates :: FilePath -> [SrcDir] -> IO (Maybe (FilePath, (FilePath, FilePath))) -detectDuplicates root srcDirs = - do pairs <- traverse (toPair root) srcDirs - return $ Map.lookupMin $ Map.mapMaybe isDup $ - Map.fromListWith OneOrMore.more pairs - - -toPair :: FilePath -> SrcDir -> IO (FilePath, OneOrMore.OneOrMore FilePath) -toPair root srcDir = - do key <- Dir.canonicalizePath (toAbsolute root srcDir) - return (key, OneOrMore.one (toGiven srcDir)) - - -isDup :: OneOrMore.OneOrMore FilePath -> Maybe (FilePath, FilePath) -isDup paths = - case paths of - OneOrMore.One _ -> Nothing - OneOrMore.More a b -> Just (OneOrMore.getFirstTwo a b) - - - --- JSON DECODE - - -type Decoder a = - D.Decoder Exit.OutlineProblem a - - -decoder :: Decoder Outline -decoder = - let - application = Json.fromChars "application" - package = Json.fromChars "package" - in - do tipe <- D.field "type" D.string - if | tipe == application -> App <$> appDecoder - | tipe == package -> Pkg <$> pkgDecoder - | otherwise -> D.failure Exit.OP_BadType - - -appDecoder :: Decoder AppOutline -appDecoder = - AppOutline - <$> D.field "elm-version" versionDecoder - <*> D.field "source-directories" dirsDecoder - <*> D.field "dependencies" (D.field "direct" (depsDecoder versionDecoder)) - <*> D.field "dependencies" (D.field "indirect" (depsDecoder versionDecoder)) - <*> D.field "test-dependencies" (D.field "direct" (depsDecoder versionDecoder)) - <*> D.field "test-dependencies" (D.field "indirect" (depsDecoder versionDecoder)) - - -pkgDecoder :: Decoder PkgOutline -pkgDecoder = - PkgOutline - <$> D.field "name" nameDecoder - <*> D.field "summary" summaryDecoder - <*> D.field "license" (Licenses.decoder Exit.OP_BadLicense) - <*> D.field "version" versionDecoder - <*> D.field "exposed-modules" exposedDecoder - <*> D.field "dependencies" (depsDecoder constraintDecoder) - <*> D.field "test-dependencies" (depsDecoder constraintDecoder) - <*> D.field "elm-version" constraintDecoder - - - --- JSON DECODE HELPERS - - -nameDecoder :: Decoder Pkg.Name -nameDecoder = - D.mapError (uncurry Exit.OP_BadPkgName) Pkg.decoder - - -summaryDecoder :: Decoder Json.String -summaryDecoder = - D.customString - (boundParser 80 Exit.OP_BadSummaryTooLong) - (\_ _ -> Exit.OP_BadSummaryTooLong) - - -versionDecoder :: Decoder V.Version -versionDecoder = - D.mapError (uncurry Exit.OP_BadVersion) V.decoder - - -constraintDecoder :: Decoder Con.Constraint -constraintDecoder = - D.mapError Exit.OP_BadConstraint Con.decoder - - -depsDecoder :: Decoder a -> Decoder (Map.Map Pkg.Name a) -depsDecoder valueDecoder = - D.dict (Pkg.keyDecoder Exit.OP_BadDependencyName) valueDecoder - - -dirsDecoder :: Decoder (NE.List SrcDir) -dirsDecoder = - fmap (toSrcDir . Json.toChars) <$> D.nonEmptyList D.string Exit.OP_NoSrcDirs - - -toSrcDir :: FilePath -> SrcDir -toSrcDir path = - if FP.isRelative path - then RelativeSrcDir path - else AbsoluteSrcDir path - - - --- EXPOSED MODULES DECODER - - -exposedDecoder :: Decoder Exposed -exposedDecoder = - D.oneOf - [ ExposedList <$> D.list moduleDecoder - , ExposedDict <$> D.pairs headerKeyDecoder (D.list moduleDecoder) - ] - - -moduleDecoder :: Decoder ModuleName.Raw -moduleDecoder = - D.mapError (uncurry Exit.OP_BadModuleName) ModuleName.decoder - - -headerKeyDecoder :: D.KeyDecoder Exit.OutlineProblem Json.String -headerKeyDecoder = - D.KeyDecoder - (boundParser 20 Exit.OP_BadModuleHeaderTooLong) - (\_ _ -> Exit.OP_BadModuleHeaderTooLong) - - - --- BOUND PARSER - - -boundParser :: Int -> x -> P.Parser x Json.String -boundParser bound tooLong = - P.Parser $ \(P.State src pos end indent row col) cok _ cerr _ -> - let - len = minusPtr end pos - newCol = col + fromIntegral len - in - if len < bound - then cok (Json.fromPtr pos end) (P.State src end end indent row newCol) - else cerr row newCol (\_ _ -> tooLong) - - - --- BINARY - - -instance Binary SrcDir where - put outline = - case outline of - AbsoluteSrcDir a -> putWord8 0 >> put a - RelativeSrcDir a -> putWord8 1 >> put a - - get = - do n <- getWord8 - case n of - 0 -> liftM AbsoluteSrcDir get - 1 -> liftM RelativeSrcDir get - _ -> fail "binary encoding of SrcDir was corrupted" diff --git a/builder/src/File.hs b/builder/src/File.hs deleted file mode 100644 index 238da0839e..0000000000 --- a/builder/src/File.hs +++ /dev/null @@ -1,231 +0,0 @@ -module File - ( Time - , getTime - , zeroTime - , writeBinary - , readBinary - , writeUtf8 - , readUtf8 - , writeBuilder - , writePackage - , exists - , remove - , removeDir - ) - where - - -import qualified Codec.Archive.Zip as Zip -import Control.Exception (catch) -import qualified Data.Binary as Binary -import qualified Data.ByteString as BS -import qualified Data.ByteString.Internal as BS -import qualified Data.ByteString.Builder as B -import qualified Data.ByteString.Lazy as LBS -import qualified Data.Fixed as Fixed -import qualified Data.List as List -import qualified Data.Time.Clock as Time -import qualified Data.Time.Clock.POSIX as Time -import qualified Foreign.ForeignPtr as FPtr -import GHC.IO.Exception (IOException, IOErrorType(InvalidArgument)) -import qualified System.Directory as Dir -import qualified System.FilePath as FP -import System.FilePath (()) -import qualified System.IO as IO -import System.IO.Error (ioeGetErrorType, annotateIOError, modifyIOError) - - - --- TIME - - -newtype Time = Time Fixed.Pico - deriving (Eq, Ord) - - -getTime :: FilePath -> IO Time -getTime path = - fmap - (Time . Time.nominalDiffTimeToSeconds . Time.utcTimeToPOSIXSeconds) - (Dir.getModificationTime path) - - -zeroTime :: Time -zeroTime = - Time 0 - - -instance Binary.Binary Time where - put (Time time) = Binary.put time - get = Time <$> Binary.get - - - --- BINARY - - -writeBinary :: (Binary.Binary a) => FilePath -> a -> IO () -writeBinary path value = - do let dir = FP.dropFileName path - Dir.createDirectoryIfMissing True dir - Binary.encodeFile path value - - -readBinary :: (Binary.Binary a) => FilePath -> IO (Maybe a) -readBinary path = - do pathExists <- Dir.doesFileExist path - if pathExists - then - do result <- Binary.decodeFileOrFail path - case result of - Right a -> - return (Just a) - - Left (offset, message) -> - do IO.hPutStrLn IO.stderr $ unlines $ - [ "+-------------------------------------------------------------------------------" - , "| Corrupt File: " ++ path - , "| Byte Offset: " ++ show offset - , "| Message: " ++ message - , "|" - , "| Please report this to https://github.com/elm/compiler/issues" - , "| Trying to continue anyway." - , "+-------------------------------------------------------------------------------" - ] - return Nothing - else - return Nothing - - - --- WRITE UTF-8 - - -writeUtf8 :: FilePath -> BS.ByteString -> IO () -writeUtf8 path content = - withUtf8 path IO.WriteMode $ \handle -> - BS.hPut handle content - - -withUtf8 :: FilePath -> IO.IOMode -> (IO.Handle -> IO a) -> IO a -withUtf8 path mode callback = - IO.withFile path mode $ \handle -> - do IO.hSetEncoding handle IO.utf8 - callback handle - - - --- READ UTF-8 - - -readUtf8 :: FilePath -> IO BS.ByteString -readUtf8 path = - withUtf8 path IO.ReadMode $ \handle -> - modifyIOError (encodingError path) $ - do fileSize <- catch (IO.hFileSize handle) useZeroIfNotRegularFile - let readSize = max 0 (fromIntegral fileSize) + 1 - hGetContentsSizeHint handle readSize (max 255 readSize) - - -useZeroIfNotRegularFile :: IOException -> IO Integer -useZeroIfNotRegularFile _ = - return 0 - - -hGetContentsSizeHint :: IO.Handle -> Int -> Int -> IO BS.ByteString -hGetContentsSizeHint handle = - readChunks [] - where - readChunks chunks readSize incrementSize = - do fp <- BS.mallocByteString readSize - readCount <- FPtr.withForeignPtr fp $ \buf -> IO.hGetBuf handle buf readSize - let chunk = BS.PS fp 0 readCount - if readCount < readSize && readSize > 0 - then return $! BS.concat (reverse (chunk:chunks)) - else readChunks (chunk:chunks) incrementSize (min 32752 (readSize + incrementSize)) - - -encodingError :: FilePath -> IOError -> IOError -encodingError path ioErr = - case ioeGetErrorType ioErr of - InvalidArgument -> - annotateIOError - (userError "Bad encoding; the file must be valid UTF-8") - "" - Nothing - (Just path) - - _ -> - ioErr - - - --- WRITE BUILDER - - -writeBuilder :: FilePath -> B.Builder -> IO () -writeBuilder path builder = - IO.withBinaryFile path IO.WriteMode $ \handle -> - do IO.hSetBuffering handle (IO.BlockBuffering Nothing) - B.hPutBuilder handle builder - - - --- WRITE PACKAGE - - -writePackage :: FilePath -> Zip.Archive -> IO () -writePackage destination archive = - case Zip.zEntries archive of - [] -> - return () - - entry:entries -> - do let root = length (Zip.eRelativePath entry) - mapM_ (writeEntry destination root) entries - - -writeEntry :: FilePath -> Int -> Zip.Entry -> IO () -writeEntry destination root entry = - let - path = drop root (Zip.eRelativePath entry) - in - if List.isPrefixOf "src/" path - || path == "LICENSE" - || path == "README.md" - || path == "elm.json" - then - if not (null path) && last path == '/' - then Dir.createDirectoryIfMissing True (destination path) - else LBS.writeFile (destination path) (Zip.fromEntry entry) - else - return () - - - --- EXISTS - - -exists :: FilePath -> IO Bool -exists path = - Dir.doesFileExist path - - - --- REMOVE FILES - - -remove :: FilePath -> IO () -remove path = - do exists_ <- Dir.doesFileExist path - if exists_ - then Dir.removeFile path - else return () - - -removeDir :: FilePath -> IO () -removeDir path = - do exists_ <- Dir.doesDirectoryExist path - if exists_ - then Dir.removeDirectoryRecursive path - else return () diff --git a/builder/src/Generate.hs b/builder/src/Generate.hs deleted file mode 100644 index 0b7f78ab59..0000000000 --- a/builder/src/Generate.hs +++ /dev/null @@ -1,211 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -module Generate - ( debug - , dev - , prod - , repl - ) - where - - -import Prelude hiding (cycle, print) -import Control.Concurrent (MVar, forkIO, newEmptyMVar, newMVar, putMVar, readMVar) -import Control.Monad (liftM2) -import qualified Data.ByteString.Builder as B -import Data.Map ((!)) -import qualified Data.Map as Map -import qualified Data.Maybe as Maybe -import qualified Data.Name as N -import qualified Data.NonEmptyList as NE - -import qualified AST.Optimized as Opt -import qualified Build -import qualified Elm.Compiler.Type.Extract as Extract -import qualified Elm.Details as Details -import qualified Elm.Interface as I -import qualified Elm.ModuleName as ModuleName -import qualified Elm.Package as Pkg -import qualified File -import qualified Generate.JavaScript as JS -import qualified Generate.Mode as Mode -import qualified Nitpick.Debug as Nitpick -import qualified Reporting.Exit as Exit -import qualified Reporting.Task as Task -import qualified Stuff - - --- NOTE: This is used by Make, Repl, and Reactor right now. But it may be --- desireable to have Repl and Reactor to keep foreign objects in memory --- to make things a bit faster? - - - --- GENERATORS - - -type Task a = - Task.Task Exit.Generate a - - -debug :: FilePath -> Details.Details -> Build.Artifacts -> Task B.Builder -debug root details (Build.Artifacts pkg ifaces roots modules) = - do loading <- loadObjects root details modules - types <- loadTypes root ifaces modules - objects <- finalizeObjects loading - let mode = Mode.Dev (Just types) - let graph = objectsToGlobalGraph objects - let mains = gatherMains pkg objects roots - return $ JS.generate mode graph mains - - -dev :: FilePath -> Details.Details -> Build.Artifacts -> Task B.Builder -dev root details (Build.Artifacts pkg _ roots modules) = - do objects <- finalizeObjects =<< loadObjects root details modules - let mode = Mode.Dev Nothing - let graph = objectsToGlobalGraph objects - let mains = gatherMains pkg objects roots - return $ JS.generate mode graph mains - - -prod :: FilePath -> Details.Details -> Build.Artifacts -> Task B.Builder -prod root details (Build.Artifacts pkg _ roots modules) = - do objects <- finalizeObjects =<< loadObjects root details modules - checkForDebugUses objects - let graph = objectsToGlobalGraph objects - let mode = Mode.Prod (Mode.shortenFieldNames graph) - let mains = gatherMains pkg objects roots - return $ JS.generate mode graph mains - - -repl :: FilePath -> Details.Details -> Bool -> Build.ReplArtifacts -> N.Name -> Task B.Builder -repl root details ansi (Build.ReplArtifacts home modules localizer annotations) name = - do objects <- finalizeObjects =<< loadObjects root details modules - let graph = objectsToGlobalGraph objects - return $ JS.generateForRepl ansi localizer graph home name (annotations ! name) - - - --- CHECK FOR DEBUG - - -checkForDebugUses :: Objects -> Task () -checkForDebugUses (Objects _ locals) = - case Map.keys (Map.filter Nitpick.hasDebugUses locals) of - [] -> return () - m:ms -> Task.throw (Exit.GenerateCannotOptimizeDebugValues m ms) - - - --- GATHER MAINS - - -gatherMains :: Pkg.Name -> Objects -> NE.List Build.Root -> Map.Map ModuleName.Canonical Opt.Main -gatherMains pkg (Objects _ locals) roots = - Map.fromList $ Maybe.mapMaybe (lookupMain pkg locals) (NE.toList roots) - - -lookupMain :: Pkg.Name -> Map.Map ModuleName.Raw Opt.LocalGraph -> Build.Root -> Maybe (ModuleName.Canonical, Opt.Main) -lookupMain pkg locals root = - let - toPair name (Opt.LocalGraph maybeMain _ _) = - (,) (ModuleName.Canonical pkg name) <$> maybeMain - in - case root of - Build.Inside name -> toPair name =<< Map.lookup name locals - Build.Outside name _ g -> toPair name g - - - --- LOADING OBJECTS - - -data LoadingObjects = - LoadingObjects - { _foreign_mvar :: MVar (Maybe Opt.GlobalGraph) - , _local_mvars :: Map.Map ModuleName.Raw (MVar (Maybe Opt.LocalGraph)) - } - - -loadObjects :: FilePath -> Details.Details -> [Build.Module] -> Task LoadingObjects -loadObjects root details modules = - Task.io $ - do mvar <- Details.loadObjects root details - mvars <- traverse (loadObject root) modules - return $ LoadingObjects mvar (Map.fromList mvars) - - -loadObject :: FilePath -> Build.Module -> IO (ModuleName.Raw, MVar (Maybe Opt.LocalGraph)) -loadObject root modul = - case modul of - Build.Fresh name _ graph -> - do mvar <- newMVar (Just graph) - return (name, mvar) - - Build.Cached name _ _ -> - do mvar <- newEmptyMVar - _ <- forkIO $ putMVar mvar =<< File.readBinary (Stuff.elmo root name) - return (name, mvar) - - - --- FINALIZE OBJECTS - - -data Objects = - Objects - { _foreign :: Opt.GlobalGraph - , _locals :: Map.Map ModuleName.Raw Opt.LocalGraph - } - - -finalizeObjects :: LoadingObjects -> Task Objects -finalizeObjects (LoadingObjects mvar mvars) = - Task.eio id $ - do result <- readMVar mvar - results <- traverse readMVar mvars - case liftM2 Objects result (sequence results) of - Just loaded -> return (Right loaded) - Nothing -> return (Left Exit.GenerateCannotLoadArtifacts) - - -objectsToGlobalGraph :: Objects -> Opt.GlobalGraph -objectsToGlobalGraph (Objects globals locals) = - foldr Opt.addLocalGraph globals locals - - - --- LOAD TYPES - - -loadTypes :: FilePath -> Map.Map ModuleName.Canonical I.DependencyInterface -> [Build.Module] -> Task Extract.Types -loadTypes root ifaces modules = - Task.eio id $ - do mvars <- traverse (loadTypesHelp root) modules - let !foreigns = Extract.mergeMany (Map.elems (Map.mapWithKey Extract.fromDependencyInterface ifaces)) - results <- traverse readMVar mvars - case sequence results of - Just ts -> return (Right (Extract.merge foreigns (Extract.mergeMany ts))) - Nothing -> return (Left Exit.GenerateCannotLoadArtifacts) - - -loadTypesHelp :: FilePath -> Build.Module -> IO (MVar (Maybe Extract.Types)) -loadTypesHelp root modul = - case modul of - Build.Fresh name iface _ -> - newMVar (Just (Extract.fromInterface name iface)) - - Build.Cached name _ ciMVar -> - do cachedInterface <- readMVar ciMVar - case cachedInterface of - Build.Unneeded -> - do mvar <- newEmptyMVar - _ <- forkIO $ - do maybeIface <- File.readBinary (Stuff.elmi root name) - putMVar mvar (Extract.fromInterface name <$> maybeIface) - return mvar - - Build.Loaded iface -> - newMVar (Just (Extract.fromInterface name iface)) - - Build.Corrupted -> - newMVar Nothing diff --git a/builder/src/Http.hs b/builder/src/Http.hs deleted file mode 100644 index e52329bb0f..0000000000 --- a/builder/src/Http.hs +++ /dev/null @@ -1,244 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module Http - ( Manager - , getManager - , toUrl - -- fetch - , get - , post - , Header - , accept - , Error(..) - -- archives - , Sha - , shaToChars - , getArchive - -- upload - , upload - , filePart - , jsonPart - , stringPart - ) - where - - -import Prelude hiding (zip) -import qualified Codec.Archive.Zip as Zip -import Control.Exception (SomeException, handle) -import qualified Data.Binary as Binary -import qualified Data.Binary.Get as Binary -import qualified Data.ByteString.Builder as B -import qualified Data.ByteString.Char8 as BS -import qualified Data.Digest.Pure.SHA as SHA -import qualified Data.String as String -import Network.HTTP (urlEncodeVars) -import Network.HTTP.Client -import Network.HTTP.Client.TLS (tlsManagerSettings) -import Network.HTTP.Types.Header (Header, hAccept, hAcceptEncoding, hUserAgent) -import Network.HTTP.Types.Method (Method, methodGet, methodPost) -import qualified Network.HTTP.Client as Multi (RequestBody(RequestBodyLBS)) -import qualified Network.HTTP.Client.MultipartFormData as Multi - -import qualified Json.Encode as Encode -import qualified Elm.Version as V - - - --- MANAGER - - -getManager :: IO Manager -getManager = - newManager tlsManagerSettings - - - --- URL - - -toUrl :: String -> [(String,String)] -> String -toUrl url params = - case params of - [] -> url - _:_ -> url ++ "?" ++ urlEncodeVars params - - - --- FETCH - - -get :: Manager -> String -> [Header] -> (Error -> e) -> (BS.ByteString -> IO (Either e a)) -> IO (Either e a) -get = - fetch methodGet - - -post :: Manager -> String -> [Header] -> (Error -> e) -> (BS.ByteString -> IO (Either e a)) -> IO (Either e a) -post = - fetch methodPost - - -fetch :: Method -> Manager -> String -> [Header] -> (Error -> e) -> (BS.ByteString -> IO (Either e a)) -> IO (Either e a) -fetch methodVerb manager url headers onError onSuccess = - handle (handleSomeException url onError) $ - handle (handleHttpException url onError) $ - do req0 <- parseUrlThrow url - let req1 = - req0 - { method = methodVerb - , requestHeaders = addDefaultHeaders headers - } - withResponse req1 manager $ \response -> - do chunks <- brConsume (responseBody response) - onSuccess (BS.concat chunks) - - -addDefaultHeaders :: [Header] -> [Header] -addDefaultHeaders headers = - (hUserAgent, userAgent) : (hAcceptEncoding, "gzip") : headers - - -{-# NOINLINE userAgent #-} -userAgent :: BS.ByteString -userAgent = - BS.pack ("elm/" ++ V.toChars V.compiler) - - -accept :: BS.ByteString -> Header -accept mime = - (hAccept, mime) - - - --- EXCEPTIONS - - -data Error - = BadUrl String String - | BadHttp String HttpExceptionContent - | BadMystery String SomeException - - -handleHttpException :: String -> (Error -> e) -> HttpException -> IO (Either e a) -handleHttpException url onError httpException = - case httpException of - InvalidUrlException _ reason -> - return (Left (onError (BadUrl url reason))) - - HttpExceptionRequest _ content -> - return (Left (onError (BadHttp url content))) - - -handleSomeException :: String -> (Error -> e) -> SomeException -> IO (Either e a) -handleSomeException url onError exception = - return (Left (onError (BadMystery url exception))) - - - --- SHA - - -type Sha = SHA.Digest SHA.SHA1State - - -shaToChars :: Sha -> String -shaToChars = - SHA.showDigest - - - --- FETCH ARCHIVE - - -getArchive - :: Manager - -> String - -> (Error -> e) - -> e - -> ((Sha, Zip.Archive) -> IO (Either e a)) - -> IO (Either e a) -getArchive manager url onError err onSuccess = - handle (handleSomeException url onError) $ - handle (handleHttpException url onError) $ - do req0 <- parseUrlThrow url - let req1 = - req0 - { method = methodGet - , requestHeaders = addDefaultHeaders [] - } - withResponse req1 manager $ \response -> - do result <- readArchive (responseBody response) - case result of - Nothing -> return (Left err) - Just shaAndArchive -> onSuccess shaAndArchive - - -readArchive :: BodyReader -> IO (Maybe (Sha, Zip.Archive)) -readArchive body = - readArchiveHelp body $ - AS 0 SHA.sha1Incremental (Binary.runGetIncremental Binary.get) - - -data ArchiveState = - AS - { _len :: !Int - , _sha :: !(Binary.Decoder SHA.SHA1State) - , _zip :: !(Binary.Decoder Zip.Archive) - } - - -readArchiveHelp :: BodyReader -> ArchiveState -> IO (Maybe (Sha, Zip.Archive)) -readArchiveHelp body (AS len sha zip) = - case zip of - Binary.Fail _ _ _ -> - return Nothing - - Binary.Partial k -> - do chunk <- brRead body - readArchiveHelp body $ - AS - { _len = len + BS.length chunk - , _sha = Binary.pushChunk sha chunk - , _zip = k (if BS.null chunk then Nothing else Just chunk) - } - - Binary.Done _ _ archive -> - return $ Just ( SHA.completeSha1Incremental sha len, archive ) - - - --- UPLOAD - - -upload :: Manager -> String -> [Multi.Part] -> IO (Either Error ()) -upload manager url parts = - handle (handleSomeException url id) $ - handle (handleHttpException url id) $ - do req0 <- parseUrlThrow url - req1 <- - Multi.formDataBody parts $ - req0 - { method = methodPost - , requestHeaders = addDefaultHeaders [] - , responseTimeout = responseTimeoutNone - } - withResponse req1 manager $ \_ -> - return (Right ()) - - -filePart :: String -> FilePath -> Multi.Part -filePart name filePath = - Multi.partFileSource (String.fromString name) filePath - - -jsonPart :: String -> FilePath -> Encode.Value -> Multi.Part -jsonPart name filePath value = - let - body = - Multi.RequestBodyLBS $ B.toLazyByteString $ Encode.encodeUgly value - in - Multi.partFileRequestBody (String.fromString name) filePath body - - -stringPart :: String -> String -> Multi.Part -stringPart name string = - Multi.partBS (String.fromString name) (BS.pack string) diff --git a/builder/src/Reporting.hs b/builder/src/Reporting.hs deleted file mode 100644 index ebba14f2c9..0000000000 --- a/builder/src/Reporting.hs +++ /dev/null @@ -1,474 +0,0 @@ -{-# LANGUAGE BangPatterns, OverloadedStrings #-} -module Reporting - ( Style - , silent - , json - , terminal - -- - , attempt - , attemptWithStyle - -- - , Key - , report - , ignorer - , ask - -- - , DKey - , DMsg(..) - , trackDetails - -- - , BKey - , BMsg(..) - , trackBuild - -- - , reportGenerate - ) - where - - -import Control.Concurrent -import Control.Exception (SomeException, AsyncException(UserInterrupt), catch, fromException, throw) -import Control.Monad (when) -import qualified Data.ByteString.Builder as B -import qualified Data.NonEmptyList as NE -import qualified System.Exit as Exit -import qualified System.Info as Info -import System.IO (hFlush, hPutStr, hPutStrLn, stderr, stdout) - -import qualified Elm.ModuleName as ModuleName -import qualified Elm.Package as Pkg -import qualified Elm.Version as V -import qualified Json.Encode as Encode -import Reporting.Doc ((<+>), (<>)) -import qualified Reporting.Doc as D -import qualified Reporting.Exit as Exit -import qualified Reporting.Exit.Help as Help - - - --- STYLE - - -data Style - = Silent - | Json - | Terminal (MVar ()) - - -silent :: Style -silent = - Silent - - -json :: Style -json = - Json - - -terminal :: IO Style -terminal = - Terminal <$> newMVar () - - - --- ATTEMPT - - -attempt :: (x -> Help.Report) -> IO (Either x a) -> IO a -attempt toReport work = - do result <- work `catch` reportExceptionsNicely - case result of - Right a -> - return a - - Left x -> - do Exit.toStderr (toReport x) - Exit.exitFailure - - -attemptWithStyle :: Style -> (x -> Help.Report) -> IO (Either x a) -> IO a -attemptWithStyle style toReport work = - do result <- work `catch` reportExceptionsNicely - case result of - Right a -> - return a - - Left x -> - case style of - Silent -> - do Exit.exitFailure - - Json -> - do B.hPutBuilder stderr (Encode.encodeUgly (Exit.toJson (toReport x))) - Exit.exitFailure - - Terminal mvar -> - do readMVar mvar - Exit.toStderr (toReport x) - Exit.exitFailure - - - --- MARKS - - -goodMark :: D.Doc -goodMark = - D.green $ if isWindows then "+" else "●" - - -badMark :: D.Doc -badMark = - D.red $ if isWindows then "X" else "✗" - - -isWindows :: Bool -isWindows = - Info.os == "mingw32" - - - --- KEY - - -newtype Key msg = Key (msg -> IO ()) - - -report :: Key msg -> msg -> IO () -report (Key send) msg = - send msg - - -ignorer :: Key msg -ignorer = - Key (\_ -> return ()) - - - --- ASK - - -ask :: D.Doc -> IO Bool -ask doc = - do Help.toStdout doc - askHelp - - -askHelp :: IO Bool -askHelp = - do hFlush stdout - input <- getLine - case input of - "" -> return True - "Y" -> return True - "y" -> return True - "n" -> return False - _ -> - do putStr "Must type 'y' for yes or 'n' for no: " - askHelp - - --- DETAILS - - -type DKey = Key DMsg - - -trackDetails :: Style -> (DKey -> IO a) -> IO a -trackDetails style callback = - case style of - Silent -> - callback (Key (\_ -> return ())) - - Json -> - callback (Key (\_ -> return ())) - - Terminal mvar -> - do chan <- newChan - - _ <- forkIO $ - do takeMVar mvar - detailsLoop chan (DState 0 0 0 0 0 0 0) - putMVar mvar () - - answer <- callback (Key (writeChan chan . Just)) - writeChan chan Nothing - return answer - - -detailsLoop :: Chan (Maybe DMsg) -> DState -> IO () -detailsLoop chan state@(DState total _ _ _ _ built _) = - do msg <- readChan chan - case msg of - Just dmsg -> - detailsLoop chan =<< detailsStep dmsg state - - Nothing -> - putStrLn $ clear (toBuildProgress total total) $ - if built == total - then "Dependencies ready!" - else "Dependency problem!" - - -data DState = - DState - { _total :: !Int - , _cached :: !Int - , _requested :: !Int - , _received :: !Int - , _failed :: !Int - , _built :: !Int - , _broken :: !Int - } - - -data DMsg - = DStart Int - | DCached - | DRequested - | DReceived Pkg.Name V.Version - | DFailed Pkg.Name V.Version - | DBuilt - | DBroken - - -detailsStep :: DMsg -> DState -> IO DState -detailsStep msg (DState total cached rqst rcvd failed built broken) = - case msg of - DStart numDependencies -> - return (DState numDependencies 0 0 0 0 0 0) - - DCached -> - putTransition (DState total (cached + 1) rqst rcvd failed built broken) - - DRequested -> - do when (rqst == 0) (putStrLn "Starting downloads...\n") - return (DState total cached (rqst + 1) rcvd failed built broken) - - DReceived pkg vsn -> - do putDownload goodMark pkg vsn - putTransition (DState total cached rqst (rcvd + 1) failed built broken) - - DFailed pkg vsn -> - do putDownload badMark pkg vsn - putTransition (DState total cached rqst rcvd (failed + 1) built broken) - - DBuilt -> - putBuilt (DState total cached rqst rcvd failed (built + 1) broken) - - DBroken -> - putBuilt (DState total cached rqst rcvd failed built (broken + 1)) - - -putDownload :: D.Doc -> Pkg.Name -> V.Version -> IO () -putDownload mark pkg vsn = - Help.toStdout $ D.indent 2 $ - mark - <+> D.fromPackage pkg - <+> D.fromVersion vsn - <> "\n" - - -putTransition :: DState -> IO DState -putTransition state@(DState total cached _ rcvd failed built broken) = - if cached + rcvd + failed < total then - return state - - else - do let char = if rcvd + failed == 0 then '\r' else '\n' - putStrFlush (char : toBuildProgress (built + broken + failed) total) - return state - - -putBuilt :: DState -> IO DState -putBuilt state@(DState total cached _ rcvd failed built broken) = - do when (total == cached + rcvd + failed) $ - putStrFlush $ '\r' : toBuildProgress (built + broken + failed) total - return state - - -toBuildProgress :: Int -> Int -> [Char] -toBuildProgress built total = - "Verifying dependencies (" ++ show built ++ "/" ++ show total ++ ")" - - -clear :: [Char] -> [Char] -> [Char] -clear before after = - '\r' : replicate (length before) ' ' ++ '\r' : after - - - --- BUILD - - -type BKey = Key BMsg - -type BResult a = Either Exit.BuildProblem a - - -trackBuild :: Style -> (BKey -> IO (BResult a)) -> IO (BResult a) -trackBuild style callback = - case style of - Silent -> - callback (Key (\_ -> return ())) - - Json -> - callback (Key (\_ -> return ())) - - Terminal mvar -> - do chan <- newChan - - _ <- forkIO $ - do takeMVar mvar - putStrFlush "Compiling ..." - buildLoop chan 0 - putMVar mvar () - - result <- callback (Key (writeChan chan . Left)) - writeChan chan (Right result) - return result - - -data BMsg - = BDone - - -buildLoop :: Chan (Either BMsg (BResult a)) -> Int -> IO () -buildLoop chan done = - do msg <- readChan chan - case msg of - Left BDone -> - do let !done1 = done + 1 - putStrFlush $ "\rCompiling (" ++ show done1 ++ ")" - buildLoop chan done1 - - Right result -> - let - !message = toFinalMessage done result - !width = 12 + length (show done) - in - putStrLn $ - if length message < width - then '\r' : replicate width ' ' ++ '\r' : message - else '\r' : message - - -toFinalMessage :: Int -> BResult a -> [Char] -toFinalMessage done result = - case result of - Right _ -> - case done of - 0 -> "Success!" - 1 -> "Success! Compiled 1 module." - n -> "Success! Compiled " ++ show n ++ " modules." - - Left problem -> - case problem of - Exit.BuildBadModules _ _ [] -> - "Detected problems in 1 module." - - Exit.BuildBadModules _ _ (_:ps) -> - "Detected problems in " ++ show (2 + length ps) ++ " modules." - - Exit.BuildProjectProblem _ -> - "Detected a problem." - - - --- GENERATE - - -reportGenerate :: Style -> NE.List ModuleName.Raw -> FilePath -> IO () -reportGenerate style names output = - case style of - Silent -> - return () - - Json -> - return () - - Terminal mvar -> - do readMVar mvar - let cnames = fmap ModuleName.toChars names - putStrLn ('\n' : toGenDiagram cnames output) - - -toGenDiagram :: NE.List [Char] -> FilePath -> [Char] -toGenDiagram (NE.List name names) output = - let - width = 3 + foldr (max . length) (length name) names - in - case names of - [] -> - toGenLine width name ('>' : ' ' : output ++ "\n") - - _:_ -> - unlines $ - toGenLine width name (vtop : hbar : hbar : '>' : ' ' : output) - : reverse (zipWith (toGenLine width) (reverse names) ([vbottom] : repeat [vmiddle])) - - -toGenLine :: Int -> [Char] -> [Char] -> [Char] -toGenLine width name end = - " " ++ name ++ ' ' : replicate (width - length name) hbar ++ end - - -hbar :: Char -hbar = if isWindows then '-' else '─' - -vtop :: Char -vtop = if isWindows then '+' else '┬' - -vmiddle :: Char -vmiddle = if isWindows then '+' else '┤' - -vbottom :: Char -vbottom = if isWindows then '+' else '┘' - - --- - - -putStrFlush :: String -> IO () -putStrFlush str = - hPutStr stdout str >> hFlush stdout - - - --- REPORT EXCEPTIONS NICELY - - -reportExceptionsNicely :: SomeException -> IO a -reportExceptionsNicely e = - case fromException e of - Just UserInterrupt -> throw e - _ -> putException e >> throw e - - -putException :: SomeException -> IO () -putException e = do - hPutStrLn stderr "" - Help.toStderr $ D.stack $ - [ D.dullyellow "-- ERROR -----------------------------------------------------------------------" - , D.reflow $ - "I ran into something that bypassed the normal error reporting process!\ - \ I extracted whatever information I could from the internal error:" - , D.vcat $ map (\line -> D.red ">" <> " " <> D.fromChars line) (lines (show e)) - , D.reflow $ - "These errors are usually pretty confusing, so start by asking around on one of\ - \ forums listed at https://elm-lang.org/community to see if anyone can get you\ - \ unstuck quickly." - , D.dullyellow "-- REQUEST ---------------------------------------------------------------------" - , D.reflow $ - "If you are feeling up to it, please try to get your code down to the smallest\ - \ version that still triggers this message. Ideally in a single Main.elm and\ - \ elm.json file." - , D.reflow $ - "From there open a NEW issue at https://github.com/elm/compiler/issues with\ - \ your reduced example pasted in directly. (Not a link to a repo or gist!) Do not\ - \ worry about if someone else saw something similar. More examples is better!" - , D.reflow $ - "This kind of error is usually tied up in larger architectural choices that are\ - \ hard to change, so even when we have a couple good examples, it can take some\ - \ time to resolve in a solid way." - ] diff --git a/builder/src/Reporting/Exit.hs b/builder/src/Reporting/Exit.hs deleted file mode 100644 index 22a006ae3f..0000000000 --- a/builder/src/Reporting/Exit.hs +++ /dev/null @@ -1,2071 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module Reporting.Exit - ( Init(..), initToReport - , Diff(..), diffToReport - , Make(..), makeToReport - , Bump(..), bumpToReport - , Repl(..), replToReport - , Publish(..), publishToReport - , Install(..), installToReport - , Reactor(..), reactorToReport - , newPackageOverview - -- - , Solver(..) - , Outline(..) - , OutlineProblem(..) - , Details(..) - , DetailsBadDep(..) - , PackageProblem(..) - , RegistryProblem(..) - , BuildProblem(..) - , BuildProjectProblem(..) - , DocsProblem(..) - , Generate(..) - -- - , toString - , toStderr - , toJson - ) - where - - -import qualified Data.ByteString as BS -import qualified Data.ByteString.UTF8 as BS_UTF8 -import qualified Data.List as List -import qualified Data.Map as Map -import qualified Data.Name as N -import qualified Data.NonEmptyList as NE -import qualified Network.HTTP.Client as HTTP -import qualified Network.HTTP.Types.Header as HTTP -import qualified Network.HTTP.Types.Status as HTTP -import qualified System.FilePath as FP -import System.FilePath ((), (<.>)) - -import qualified Elm.Constraint as C -import qualified Elm.Magnitude as M -import qualified Elm.ModuleName as ModuleName -import qualified Elm.Package as Pkg -import qualified Elm.Version as V -import qualified File -import qualified Http -import qualified Json.Decode as Decode -import qualified Json.Encode as Encode -import qualified Json.String as Json -import Parse.Primitives (Row, Col) -import qualified Reporting.Annotation as A -import Reporting.Doc ((<>)) -import qualified Reporting.Doc as D -import qualified Reporting.Error.Import as Import -import qualified Reporting.Error.Json as Json -import qualified Reporting.Exit.Help as Help -import qualified Reporting.Error as Error -import qualified Reporting.Render.Code as Code - - - --- RENDERERS - - -toString :: Help.Report -> String -toString report = - Help.toString (Help.reportToDoc report) - - -toStderr :: Help.Report -> IO () -toStderr report = - Help.toStderr (Help.reportToDoc report) - - -toJson :: Help.Report -> Encode.Value -toJson report = - Help.reportToJson report - - - --- INIT - - -data Init - = InitNoSolution [Pkg.Name] - | InitNoOfflineSolution [Pkg.Name] - | InitSolverProblem Solver - | InitAlreadyExists - | InitRegistryProblem RegistryProblem - - -initToReport :: Init -> Help.Report -initToReport exit = - case exit of - InitNoSolution pkgs -> - Help.report "NO SOLUTION" Nothing - "I tried to create an elm.json with the following direct dependencies:" - [ D.indent 4 $ D.vcat $ - map (D.dullyellow . D.fromChars . Pkg.toChars) pkgs - , D.reflow $ - "I could not find compatible versions though! This should not happen, so please\ - \ ask around one of the community forums at https://elm-lang.org/community to learn\ - \ what is going on!" - ] - - InitNoOfflineSolution pkgs -> - Help.report "NO OFFLINE SOLUTION" Nothing - "I tried to create an elm.json with the following direct dependencies:" - [ D.indent 4 $ D.vcat $ - map (D.dullyellow . D.fromChars . Pkg.toChars) pkgs - , D.reflow $ - "I could not find compatible versions though, but that may be because I could not\ - \ connect to https://package.elm-lang.org to get the latest list of packages. Are\ - \ you able to connect to the internet? Please ask around one of the community\ - \ forums at https://elm-lang.org/community for help!" - ] - - InitSolverProblem solver -> - toSolverReport solver - - InitAlreadyExists -> - Help.report "EXISTING PROJECT" Nothing - "You already have an elm.json file, so there is nothing for me to initialize!" - [ D.fillSep - ["Maybe",D.green (D.fromChars (D.makeLink "init")),"can","help" - ,"you","figure","out","what","to","do","next?" - ] - ] - - InitRegistryProblem problem -> - toRegistryProblemReport "PROBLEM LOADING PACKAGE LIST" problem $ - "I need the list of published packages before I can start initializing projects" - - - --- DIFF - - -data Diff - = DiffNoOutline - | DiffBadOutline Outline - | DiffApplication - | DiffNoExposed - | DiffUnpublished - | DiffUnknownPackage Pkg.Name [Pkg.Name] - | DiffUnknownVersion Pkg.Name V.Version [V.Version] - | DiffDocsProblem V.Version DocsProblem - | DiffMustHaveLatestRegistry RegistryProblem - | DiffBadDetails Details - | DiffBadBuild BuildProblem - - -diffToReport :: Diff -> Help.Report -diffToReport diff = - case diff of - DiffNoOutline -> - Help.report "DIFF WHAT?" Nothing - "I cannot find an elm.json so I am not sure what you want me to diff.\ - \ Normally you run `elm diff` from within a project!" - [ D.reflow $ "If you are just curious to see a diff, try running this command:" - , D.indent 4 $ D.green $ "elm diff elm/http 1.0.0 2.0.0" - ] - - DiffBadOutline outline -> - toOutlineReport outline - - DiffApplication -> - Help.report "CANNOT DIFF APPLICATIONS" (Just "elm.json") - "Your elm.json says this project is an application, but `elm diff` only works\ - \ with packages. That way there are previously published versions of the API to\ - \ diff against!" - [ D.reflow $ "If you are just curious to see a diff, try running this command:" - , D.indent 4 $ D.dullyellow $ "elm diff elm/json 1.0.0 1.1.2" - ] - - DiffNoExposed -> - Help.report "NO EXPOSED MODULES" (Just "elm.json") - "Your elm.json has no \"exposed-modules\" which means there is no public API at\ - \ all right now! What am I supposed to diff?" - [ D.reflow $ - "Try adding some modules back to the \"exposed-modules\" field." - ] - - DiffUnpublished -> - Help.report "UNPUBLISHED" Nothing - "This package is not published yet. There is nothing to diff against!" - [] - - DiffUnknownPackage pkg suggestions -> - Help.report "UNKNOWN PACKAGE" Nothing - ( "I cannot find a package called:" - ) - [ D.indent 4 $ D.red $ D.fromChars $ Pkg.toChars pkg - , "Maybe you want one of these instead?" - , D.indent 4 $ D.dullyellow $ D.vcat $ map (D.fromChars . Pkg.toChars) suggestions - , "But check to see all possibilities!" - ] - - DiffUnknownVersion _pkg vsn realVersions -> - Help.docReport "UNKNOWN VERSION" Nothing - ( D.fillSep $ - [ "Version", D.red (D.fromVersion vsn) - , "has", "never", "been", "published,", "so", "I" - , "cannot", "diff", "against", "it." - ] - ) - [ "Here are all the versions that HAVE been published:" - , D.indent 4 $ D.dullyellow $ D.vcat $ - let - sameMajor v1 v2 = V._major v1 == V._major v2 - mkRow vsns = D.hsep $ map D.fromVersion vsns - in - map mkRow $ List.groupBy sameMajor (List.sort realVersions) - , "Want one of those instead?" - ] - - DiffDocsProblem version problem -> - toDocsProblemReport problem $ - "I need the docs for " ++ V.toChars version ++ " to compute this diff" - - DiffMustHaveLatestRegistry problem -> - toRegistryProblemReport "PROBLEM UPDATING PACKAGE LIST" problem $ - "I need the latest list of published packages before I do this diff" - - DiffBadDetails details -> - toDetailsReport details - - DiffBadBuild buildProblem -> - toBuildProblemReport buildProblem - - - --- BUMP - - -data Bump - = BumpNoOutline - | BumpBadOutline Outline - | BumpApplication - | BumpUnexpectedVersion V.Version [V.Version] - | BumpMustHaveLatestRegistry RegistryProblem - | BumpCannotFindDocs Pkg.Name V.Version DocsProblem - | BumpBadDetails Details - | BumpNoExposed - | BumpBadBuild BuildProblem - - -bumpToReport :: Bump -> Help.Report -bumpToReport bump = - case bump of - BumpNoOutline -> - Help.report "BUMP WHAT?" Nothing - "I cannot find an elm.json so I am not sure what you want me to bump." - [ D.reflow $ - "Elm packages always have an elm.json that says current the version number. If\ - \ you run this command from a directory with an elm.json file, I will try to bump\ - \ the version in there based on the API changes." - ] - - BumpBadOutline outline -> - toOutlineReport outline - - BumpApplication -> - Help.report "CANNOT BUMP APPLICATIONS" (Just "elm.json") - "Your elm.json says this is an application. That means it cannot be published\ - \ on and therefore has no version to bump!" - [] - - BumpUnexpectedVersion vsn versions -> - Help.docReport "CANNOT BUMP" (Just "elm.json") - ( D.fillSep - ["Your","elm.json","says","I","should","bump","relative","to","version" - ,D.red (D.fromVersion vsn) <> "," - ,"but","I","cannot","find","that","version","on","." - ,"That","means","there","is","no","API","for","me","to","diff","against","and" - ,"figure","out","if","these","are","MAJOR,","MINOR,","or","PATCH","changes." - ] - ) - [ D.fillSep $ - ["Try","bumping","again","after","changing","the",D.dullyellow "\"version\"","in","elm.json"] - ++ if length versions == 1 then ["to:"] else ["to","one","of","these:"] - , D.vcat $ map (D.green . D.fromVersion) versions - ] - - BumpMustHaveLatestRegistry problem -> - toRegistryProblemReport "PROBLEM UPDATING PACKAGE LIST" problem $ - "I need the latest list of published packages before I can bump any versions" - - BumpCannotFindDocs _ version problem -> - toDocsProblemReport problem $ - "I need the docs for " ++ V.toChars version ++ " to compute the next version number" - - BumpBadDetails details -> - toDetailsReport details - - BumpNoExposed -> - Help.docReport "NO EXPOSED MODULES" (Just "elm.json") - ( D.fillSep $ - [ "To", "bump", "a", "package,", "the" - , D.dullyellow "\"exposed-modules\"", "field", "of", "your" - , "elm.json", "must", "list", "at", "least", "one", "module." - ] - ) - [ D.reflow $ - "Try adding some modules back to the \"exposed-modules\" field." - ] - - BumpBadBuild problem -> - toBuildProblemReport problem - - - --- OVERVIEW OF VERSIONING - - -newPackageOverview :: String -newPackageOverview = - unlines - [ "This package has never been published before. Here's how things work:" - , "" - , " - Versions all have exactly three parts: MAJOR.MINOR.PATCH" - , "" - , " - All packages start with initial version " ++ V.toChars V.one - , "" - , " - Versions are incremented based on how the API changes:" - , "" - , " PATCH = the API is the same, no risk of breaking code" - , " MINOR = values have been added, existing values are unchanged" - , " MAJOR = existing values have been changed or removed" - , "" - , " - I will bump versions for you, automatically enforcing these rules" - , "" - ] - - - --- PUBLISH - - -data Publish - = PublishNoOutline - | PublishBadOutline Outline - | PublishBadDetails Details - | PublishMustHaveLatestRegistry RegistryProblem - | PublishApplication - | PublishNotInitialVersion V.Version - | PublishAlreadyPublished V.Version - | PublishInvalidBump V.Version V.Version - | PublishBadBump V.Version V.Version M.Magnitude V.Version M.Magnitude - | PublishNoSummary - | PublishNoExposed - | PublishNoReadme - | PublishShortReadme - | PublishNoLicense - | PublishBuildProblem BuildProblem - | PublishMissingTag V.Version - | PublishCannotGetTag V.Version Http.Error - | PublishCannotGetTagData V.Version String BS.ByteString - | PublishCannotGetZip Http.Error - | PublishCannotDecodeZip String - | PublishCannotGetDocs V.Version V.Version DocsProblem - | PublishCannotRegister Http.Error - | PublishNoGit - | PublishLocalChanges V.Version - -- - | PublishZipBadDetails Details - | PublishZipApplication - | PublishZipNoExposed - | PublishZipBuildProblem BuildProblem - - -publishToReport :: Publish -> Help.Report -publishToReport publish = - case publish of - PublishNoOutline -> - Help.report "PUBLISH WHAT?" Nothing - "I cannot find an elm.json so I am not sure what you want me to publish." - [ D.reflow $ - "Elm packages always have an elm.json that states the version number,\ - \ dependencies, exposed modules, etc." - ] - - PublishBadOutline outline -> - toOutlineReport outline - - PublishBadDetails problem -> - toDetailsReport problem - - PublishMustHaveLatestRegistry problem -> - toRegistryProblemReport "PROBLEM UPDATING PACKAGE LIST" problem $ - "I need the latest list of published packages to make sure this is safe to publish" - - PublishApplication -> - Help.report "UNPUBLISHABLE" Nothing "I cannot publish applications, only packages!" [] - - PublishNotInitialVersion vsn -> - Help.docReport "INVALID VERSION" Nothing - ( D.fillSep - ["I","cannot","publish" - ,D.red (D.fromVersion vsn) - ,"as","the","initial","version." - ] - ) - [ D.fillSep - ["Change","it","to",D.green "1.0.0","which","is" - ,"the","initial","version","for","all","Elm","packages." - ] - ] - - PublishAlreadyPublished vsn -> - Help.docReport "ALREADY PUBLISHED" Nothing - ( D.vcat - [ D.fillSep - [ "Version", D.green (D.fromVersion vsn) - , "has", "already", "been", "published.", "You", "cannot" - , "publish", "it", "again!" - ] - , "Try using the `bump` command:" - ] - ) - [ D.dullyellow $ D.indent 4 "elm bump" - , D.reflow $ - "It computes the version number based on API changes, ensuring\ - \ that no breaking changes end up in PATCH releases!" - ] - - PublishInvalidBump statedVersion latestVersion -> - Help.docReport "INVALID VERSION" (Just "elm.json") - ( D.fillSep $ - ["Your","elm.json","says","the","next","version","should","be" - ,D.red (D.fromVersion statedVersion) <> "," - ,"but","that","is","not","valid","based","on","the","previously" - ,"published","versions." - ] - ) - [ D.fillSep $ - ["Change","the","version","back","to" - ,D.green (D.fromVersion latestVersion) - ,"which","is","the","most","recently","published","version." - ,"From","there,","have","Elm","bump","the","version","by","running:" - ] - , D.indent 4 $ D.green "elm bump" - , D.reflow $ - "If you want more insight on the API changes Elm detects, you\ - \ can run `elm diff` at this point as well." - ] - - PublishBadBump old new magnitude realNew realMagnitude -> - Help.docReport "INVALID VERSION" (Just "elm.json") - ( - D.fillSep $ - ["Your","elm.json","says","the","next","version","should","be" - ,D.red (D.fromVersion new) <> "," - ,"indicating","a",D.fromChars (M.toChars magnitude) - ,"change","to","the","public","API." - ,"This","does","not","match","the","API","diff","given","by:" - ] - ) - [ D.indent 4 $ D.fromChars $ - "elm diff " ++ V.toChars old - - , D.fillSep $ - ["This","command","says","this","is","a" - ,D.fromChars (M.toChars realMagnitude) - ,"change,","so","the","next","version","should","be" - ,D.green (D.fromVersion realNew) <> "." - ,"Double","check","everything","to","make","sure","you" - ,"are","publishing","what","you","want!" - ] - , D.reflow $ - "Also, next time use `elm bump` and I'll figure all this out for you!" - ] - - PublishNoSummary -> - Help.docReport "NO SUMMARY" (Just "elm.json") - ( D.fillSep $ - [ "To", "publish", "a", "package,", "your", "elm.json", "must" - , "have", "a", D.dullyellow "\"summary\"", "field", "that", "gives" - , "a", "consice", "overview", "of", "your", "project." - ] - ) - [ D.reflow $ - "The summary must be less than 80 characters. It should describe\ - \ the concrete use of your package as clearly and as plainly as possible." - ] - - PublishNoExposed -> - Help.docReport "NO EXPOSED MODULES" (Just "elm.json") - ( D.fillSep $ - [ "To", "publish", "a", "package,", "the" - , D.dullyellow "\"exposed-modules\"", "field", "of", "your" - , "elm.json", "must", "list", "at", "least", "one", "module." - ] - ) - [ D.reflow $ - "Which modules do you want users of the package to have access to? Add their\ - \ names to the \"exposed-modules\" list." - ] - - PublishNoReadme -> - toBadReadmeReport "NO README" $ - "Every published package must have a helpful README.md\ - \ file, but I do not see one in your project." - - PublishShortReadme -> - toBadReadmeReport "SHORT README" $ - "This README.md is too short. Having more details will help\ - \ people assess your package quickly and fairly." - - PublishNoLicense -> - Help.report "NO LICENSE FILE" (Just "LICENSE") - "By publishing a package you are inviting the Elm community to build\ - \ upon your work. But without knowing your license, we have no idea if\ - \ that is legal!" - [ D.reflow $ - "Once you pick an OSI approved license from ,\ - \ you must share that choice in two places. First, the license\ - \ identifier must appear in your elm.json file. Second, the full\ - \ license text must appear in the root of your project in a file\ - \ named LICENSE. Add that file and you will be all set!" - ] - - PublishBuildProblem buildProblem -> - toBuildProblemReport buildProblem - - PublishMissingTag version -> - let vsn = V.toChars version in - Help.docReport "NO TAG" Nothing - ( D.fillSep $ - [ "Packages", "must", "be", "tagged", "in", "git,", "but", "I" - , "cannot", "find", "a", D.green (D.fromChars vsn), "tag." - ] - ) - [ D.vcat - [ "These tags make it possible to find this specific version on GitHub." - , "To tag the most recent commit and push it to GitHub, run this:" - ] - , D.indent 4 $ D.dullyellow $ D.vcat $ map D.fromChars $ - [ "git tag -a " ++ vsn ++ " -m \"new release\"" - , "git push origin " ++ vsn - ] - , "The -m flag is for a helpful message. Try to make it more informative!" - ] - - PublishCannotGetTag version httpError -> - case httpError of - Http.BadHttp _ (HTTP.StatusCodeException response _) - | HTTP.statusCode (HTTP.responseStatus response) == 404 -> - let vsn = V.toChars version in - Help.report "NO TAG ON GITHUB" Nothing - ("You have version " ++ vsn ++ " tagged locally, but not on GitHub.") - [ D.reflow - "Run the following command to make this tag available on GitHub:" - , D.indent 4 $ D.dullyellow $ D.fromChars $ - "git push origin " ++ vsn - , D.reflow - "This will make it possible to find your code online based on the version number." - ] - - _ -> - toHttpErrorReport "PROBLEM VERIFYING TAG" httpError - "I need to check that the version tag is registered on GitHub" - - PublishCannotGetTagData version url body -> - Help.report "PROBLEM VERIFYING TAG" Nothing - ("I need to check that version " ++ V.toChars version ++ " is tagged on GitHub, so I fetched:") - [ D.indent 4 $ D.dullyellow $ D.fromChars url - , D.reflow $ - "I got the data back, but it was not what I was expecting. The response\ - \ body contains " ++ show (BS.length body) ++ " bytes. Here is the " - ++ if BS.length body <= 76 then "whole thing:" else "beginning:" - , D.indent 4 $ D.dullyellow $ D.fromChars $ - if BS.length body <= 76 - then BS_UTF8.toString body - else take 73 (BS_UTF8.toString body) ++ "..." - , D.reflow $ - "Does this error keep showing up? Maybe there is something weird with your\ - \ internet connection. We have gotten reports that schools, businesses,\ - \ airports, etc. sometimes intercept requests and add things to the body\ - \ or change its contents entirely. Could that be the problem?" - ] - - PublishCannotGetZip httpError -> - toHttpErrorReport "PROBLEM DOWNLOADING CODE" httpError $ - "I need to check that folks can download and build the source code when they\ - \ install this package" - - PublishCannotDecodeZip url -> - Help.report "PROBLEM DOWNLOADING CODE" Nothing - "I need to check that folks can download and build the source code when they\ - \ install this package, so I downloaded the code from:" - [ D.indent 4 $ D.dullyellow $ D.fromChars url - , D.reflow $ - "I was unable to unzip the archive though. Maybe there is something weird with\ - \ your internet connection. We have gotten reports that schools, businesses,\ - \ airports, etc. sometimes intercept requests and add things to the body or\ - \ change its contents entirely. Could that be the problem?" - ] - - PublishCannotGetDocs old new docsProblem -> - toDocsProblemReport docsProblem $ - "I need the docs for " ++ V.toChars old ++ " to verify that " - ++ V.toChars new ++ " really does come next" - - PublishCannotRegister httpError -> - toHttpErrorReport "PROBLEM PUBLISHING PACKAGE" httpError $ - "I need to send information about your package to the package website" - - PublishNoGit -> - Help.report "NO GIT" Nothing - "I searched your PATH environment variable for `git` and could not\ - \ find it. Is it available through your PATH?" - [ D.reflow $ - "Who cares about this? Well, I currently use `git` to check if there\ - \ are any local changes in your code. Local changes are a good sign\ - \ that some important improvements have gotten mistagged, so this\ - \ check can be extremely helpful for package authors!" - , D.toSimpleNote $ - "We plan to do this without the `git` binary in a future release." - ] - - PublishLocalChanges version -> - let vsn = V.toChars version in - Help.docReport "LOCAL CHANGES" Nothing - ( D.fillSep $ - [ "The", "code", "tagged", "as", D.green (D.fromChars vsn), "in" - , "git", "does", "not", "match", "the", "code", "in", "your" - , "working", "directory.", "This", "means", "you", "have" - , "commits", "or", "local", "changes", "that", "are", "not" - , "going", "to", "be", "published!" - ] - ) - [ D.toSimpleNote $ - "If you are sure everything is in order, you can run `git checkout " - ++ vsn ++ "` and publish your code from there." - ] - - PublishZipBadDetails _ -> - badZipReport - - PublishZipApplication -> - badZipReport - - PublishZipNoExposed -> - badZipReport - - PublishZipBuildProblem _ -> - badZipReport - - -toBadReadmeReport :: String -> String -> Help.Report -toBadReadmeReport title summary = - Help.report title (Just "README.md") summary - [ D.reflow $ - "When people look at your README, they are wondering:" - , D.vcat - [ " - What does this package even do?" - , " - Will it help me solve MY problems?" - ] - , D.reflow $ - "So I recommend starting your README with a small example of the\ - \ most common usage scenario. Show people what they can expect if\ - \ they learn more!" - , D.toSimpleNote $ - "By publishing your package, you are inviting people to invest time in\ - \ understanding your work. Spending an hour on your README to communicate your\ - \ knowledge more clearly can save the community days or weeks of time in\ - \ aggregate, and saving time in aggregate is the whole point of publishing\ - \ packages! People really appreciate it, and it makes the whole ecosystem feel\ - \ nicer!" - ] - - -badZipReport :: Help.Report -badZipReport = - Help.report "PROBLEM VERIFYING PACKAGE" Nothing - "Before publishing packages, I download the code from GitHub and try to build it\ - \ from scratch. That way I can be more confident that it will work for other\ - \ people too. But I am not able to build it!" - [ D.reflow $ - "I was just able to build your local copy though. Is there some way the version\ - \ on GitHub could be different?" - ] - - - --- DOCS - - -data DocsProblem - = DP_Http Http.Error - | DP_Data String BS.ByteString - | DP_Cache - - -toDocsProblemReport :: DocsProblem -> String -> Help.Report -toDocsProblemReport problem context = - case problem of - DP_Http httpError -> - toHttpErrorReport "PROBLEM LOADING DOCS" httpError context - - DP_Data url body -> - Help.report "PROBLEM LOADING DOCS" Nothing (context ++ ", so I fetched:") - [ D.indent 4 $ D.dullyellow $ D.fromChars url - , D.reflow $ - "I got the data back, but it was not what I was expecting. The response\ - \ body contains " ++ show (BS.length body) ++ " bytes. Here is the " - ++ if BS.length body <= 76 then "whole thing:" else "beginning:" - , D.indent 4 $ D.dullyellow $ D.fromChars $ - if BS.length body <= 76 - then BS_UTF8.toString body - else take 73 (BS_UTF8.toString body) ++ "..." - , D.reflow $ - "Does this error keep showing up? Maybe there is something weird with your\ - \ internet connection. We have gotten reports that schools, businesses,\ - \ airports, etc. sometimes intercept requests and add things to the body\ - \ or change its contents entirely. Could that be the problem?" - ] - - DP_Cache -> - Help.report "PROBLEM LOADING DOCS" Nothing (context ++ ", but the local copy seems to be corrupted.") - [ D.reflow $ - "I deleted the cached version, so the next run should download a fresh copy of\ - \ the docs. Hopefully that will get you unstuck, but it will not resolve the root\ - \ problem if, for example, a 3rd party editor plugin is modifing cached files\ - \ for some reason." - ] - - - --- INSTALL - - -data Install - = InstallNoOutline - | InstallBadOutline Outline - | InstallBadRegistry RegistryProblem - | InstallNoArgs FilePath - | InstallNoOnlineAppSolution Pkg.Name - | InstallNoOfflineAppSolution Pkg.Name - | InstallNoOnlinePkgSolution Pkg.Name - | InstallNoOfflinePkgSolution Pkg.Name - | InstallHadSolverTrouble Solver - | InstallUnknownPackageOnline Pkg.Name [Pkg.Name] - | InstallUnknownPackageOffline Pkg.Name [Pkg.Name] - | InstallBadDetails Details - - -installToReport :: Install -> Help.Report -installToReport exit = - case exit of - InstallNoOutline -> - Help.report "NEW PROJECT?" Nothing - "Are you trying to start a new project? Try this command instead:" - [ D.indent 4 $ D.green "elm init" - , D.reflow "It will help you get started!" - ] - - InstallBadOutline outline -> - toOutlineReport outline - - InstallBadRegistry problem -> - toRegistryProblemReport "PROBLEM LOADING PACKAGE LIST" problem $ - "I need the list of published packages to figure out how to install things" - - InstallNoArgs elmHome -> - Help.report "INSTALL WHAT?" Nothing - "I am expecting commands like:" - [ D.green $ D.indent 4 $ D.vcat $ - [ "elm install elm/http" - , "elm install elm/json" - , "elm install elm/random" - ] - , D.toFancyHint - ["In","JavaScript","folks","run","`npm install`","to","start","projects." - ,"\"Gotta","download","everything!\"","But","why","download","packages" - ,"again","and","again?","Instead,","Elm","caches","packages","in" - ,D.dullyellow (D.fromChars elmHome) - ,"so","each","one","is","downloaded","and","built","ONCE","on","your","machine." - ,"Elm","projects","check","that","cache","before","trying","the","internet." - ,"This","reduces","build","times,","reduces","server","costs,","and","makes","it" - ,"easier","to","work","offline.","As","a","result" - ,D.dullcyan "elm install","is","only","for","adding","dependencies","to","elm.json," - ,"whereas",D.dullcyan "elm make","is","in","charge","of","gathering","dependencies" - ,"and","building","everything.","So","maybe","try",D.green "elm make","instead?" - ] - ] - - InstallNoOnlineAppSolution pkg -> - Help.report "CANNOT FIND COMPATIBLE VERSION" (Just "elm.json") - ( - "I cannot find a version of " ++ Pkg.toChars pkg ++ " that is compatible\ - \ with your existing dependencies." - ) - [ D.reflow $ - "I checked all the published versions. When that failed, I tried to find any\ - \ compatible combination of these packages, even if it meant changing all your\ - \ existing dependencies! That did not work either!" - , D.reflow $ - "This is most likely to happen when a package is not upgraded yet. Maybe a new\ - \ version of Elm came out recently? Maybe a common package was changed recently?\ - \ Maybe a better package came along, so there was no need to upgrade this one?\ - \ Try asking around https://elm-lang.org/community to learn what might be going on\ - \ with this package." - , D.toSimpleNote $ - "Whatever the case, please be kind to the relevant package authors! Having\ - \ friendly interactions with users is great motivation, and conversely, getting\ - \ berated by strangers on the internet sucks your soul dry. Furthermore, package\ - \ authors are humans with families, friends, jobs, vacations, responsibilities,\ - \ goals, etc. They face obstacles outside of their technical work you will never\ - \ know about, so please assume the best and try to be patient and supportive!" - ] - - InstallNoOfflineAppSolution pkg -> - Help.report "CANNOT FIND COMPATIBLE VERSION LOCALLY" (Just "elm.json") - ( - "I cannot find a version of " ++ Pkg.toChars pkg ++ " that is compatible\ - \ with your existing dependencies." - ) - [ D.reflow $ - "I was not able to connect to https://package.elm-lang.org/ though, so I was only\ - \ able to look through packages that you have downloaded in the past." - , D.reflow $ - "Try again later when you have internet!" - ] - - InstallNoOnlinePkgSolution pkg -> - Help.report "CANNOT FIND COMPATIBLE VERSION" (Just "elm.json") - ( - "I cannot find a version of " ++ Pkg.toChars pkg ++ " that is compatible\ - \ with your existing constraints." - ) - [ D.reflow $ - "With applications, I try to broaden the constraints to see if anything works,\ - \ but messing with package constraints is much more delicate business. E.g. making\ - \ your constraints stricter may make it harder for applications to find compatible\ - \ dependencies. So fixing something here may break it for a lot of other people!" - , D.reflow $ - "So I recommend making an application with the same dependencies as your package.\ - \ See if there is a solution at all. From there it may be easier to figure out\ - \ how to proceed in a way that will disrupt your users as little as possible. And\ - \ the solution may be to help other package authors to get their packages updated,\ - \ or to drop a dependency entirely." - ] - - InstallNoOfflinePkgSolution pkg -> - Help.report "CANNOT FIND COMPATIBLE VERSION LOCALLY" (Just "elm.json") - ( - "I cannot find a version of " ++ Pkg.toChars pkg ++ " that is compatible\ - \ with your existing constraints." - ) - [ D.reflow $ - "I was not able to connect to https://package.elm-lang.org/ though, so I was only\ - \ able to look through packages that you have downloaded in the past." - , D.reflow $ - "Try again later when you have internet!" - ] - - InstallHadSolverTrouble solver -> - toSolverReport solver - - InstallUnknownPackageOnline pkg suggestions -> - Help.docReport "UNKNOWN PACKAGE" Nothing - ( - D.fillSep - ["I","cannot","find","a","package","named",D.red (D.fromPackage pkg) <> "."] - ) - [ D.reflow $ - "I looked through https://package.elm-lang.org for packages with similar names\ - \ and found these:" - , D.indent 4 $ D.dullyellow $ D.vcat $ map D.fromPackage suggestions - , D.reflow $ "Maybe you want one of these instead?" - ] - - InstallUnknownPackageOffline pkg suggestions -> - Help.docReport "UNKNOWN PACKAGE" Nothing - ( - D.fillSep - ["I","cannot","find","a","package","named",D.red (D.fromPackage pkg) <> "."] - ) - [ D.reflow $ - "I could not connect to https://package.elm-lang.org though, so new packages may\ - \ have been published since I last updated my local cache of package names." - , D.reflow $ - "Looking through the locally cached names, the closest ones are:" - , D.indent 4 $ D.dullyellow $ D.vcat $ map D.fromPackage suggestions - , D.reflow $ "Maybe you want one of these instead?" - ] - - InstallBadDetails details -> - toDetailsReport details - - - --- SOLVER - - -data Solver - = SolverBadCacheData Pkg.Name V.Version - | SolverBadHttpData Pkg.Name V.Version String - | SolverBadHttp Pkg.Name V.Version Http.Error - - -toSolverReport :: Solver -> Help.Report -toSolverReport problem = - case problem of - SolverBadCacheData pkg vsn -> - Help.report "PROBLEM SOLVING PACKAGE CONSTRAINTS" Nothing - ( - "I need the elm.json of " ++ Pkg.toChars pkg ++ " " ++ V.toChars vsn ++ " to\ - \ help me search for a set of compatible packages. I had it cached locally, but\ - \ it looks like the file was corrupted!" - ) - [ D.reflow $ - "I deleted the cached version, so the next run should download a fresh copy.\ - \ Hopefully that will get you unstuck, but it will not resolve the root\ - \ problem if a 3rd party tool is modifing cached files for some reason." - ] - - SolverBadHttpData pkg vsn url -> - Help.report "PROBLEM SOLVING PACKAGE CONSTRAINTS" Nothing - ( - "I need the elm.json of " ++ Pkg.toChars pkg ++ " " ++ V.toChars vsn ++ " to\ - \ help me search for a set of compatible packages, but I ran into corrupted\ - \ information from:" - ) - [ D.indent 4 $ D.dullyellow $ D.fromChars url - , D.reflow $ - "Is something weird with your internet connection. We have gotten reports that\ - \ schools, businesses, airports, etc. sometimes intercept requests and add things\ - \ to the body or change its contents entirely. Could that be the problem?" - ] - - SolverBadHttp pkg vsn httpError -> - toHttpErrorReport "PROBLEM SOLVING PACKAGE CONSTRAINTS" httpError $ - "I need the elm.json of " ++ Pkg.toChars pkg ++ " " ++ V.toChars vsn - ++ " to help me search for a set of compatible packages" - - - --- OUTLINE - - -data Outline - = OutlineHasBadStructure (Decode.Error OutlineProblem) - | OutlineHasMissingSrcDirs FilePath [FilePath] - | OutlineHasDuplicateSrcDirs FilePath FilePath FilePath - | OutlineNoPkgCore - | OutlineNoAppCore - | OutlineNoAppJson - - -data OutlineProblem - = OP_BadType - | OP_BadPkgName Row Col - | OP_BadVersion Row Col - | OP_BadConstraint C.Error - | OP_BadModuleName Row Col - | OP_BadModuleHeaderTooLong - | OP_BadDependencyName Row Col - | OP_BadLicense Json.String [Json.String] - | OP_BadSummaryTooLong - | OP_NoSrcDirs - - -toOutlineReport :: Outline -> Help.Report -toOutlineReport problem = - case problem of - OutlineHasBadStructure decodeError -> - Json.toReport "elm.json" (Json.FailureToReport toOutlineProblemReport) decodeError $ - Json.ExplicitReason "I ran into a problem with your elm.json file." - - OutlineHasMissingSrcDirs dir dirs -> - case dirs of - [] -> - Help.report "MISSING SOURCE DIRECTORY" (Just "elm.json") - "I need a valid elm.json file, but the \"source-directories\" field lists the following directory:" - [ D.indent 4 $ D.red $ D.fromChars dir - , D.reflow $ - "I cannot find it though. Is it missing? Is there a typo?" - ] - - _:_ -> - Help.report "MISSING SOURCE DIRECTORIES" (Just "elm.json") - "I need a valid elm.json file, but the \"source-directories\" field lists the following directories:" - [ D.indent 4 $ D.vcat $ - map (D.red . D.fromChars) (dir:dirs) - , D.reflow $ - "I cannot find them though. Are they missing? Are there typos?" - ] - - OutlineHasDuplicateSrcDirs canonicalDir dir1 dir2 -> - if dir1 == dir2 then - Help.report "REDUNDANT SOURCE DIRECTORIES" (Just "elm.json") - "I need a valid elm.json file, but the \"source-directories\" field lists the same directory twice:" - [ D.indent 4 $ D.vcat $ - map (D.red . D.fromChars) [dir1,dir2] - , D.reflow $ - "Remove one of the entries!" - ] - else - Help.report "REDUNDANT SOURCE DIRECTORIES" (Just "elm.json") - "I need a valid elm.json file, but the \"source-directories\" field has some redundant directories:" - [ D.indent 4 $ D.vcat $ - map (D.red . D.fromChars) [dir1,dir2] - , D.reflow $ - "These are two different ways of refering to the same directory:" - , D.indent 4 $ D.dullyellow $ D.fromChars canonicalDir - , D.reflow $ - "Remove one of the redundant entries from your \"source-directories\" field." - ] - - OutlineNoPkgCore -> - Help.report "MISSING DEPENDENCY" (Just "elm.json") - "I need to see an \"elm/core\" dependency your elm.json file. The default imports\ - \ of `List` and `Maybe` do not work without it." - [ D.reflow $ - "If you modified your elm.json by hand, try to change it back! And if you are\ - \ having trouble getting back to a working elm.json, it may be easier to find a\ - \ working package and start fresh with their elm.json file." - ] - - OutlineNoAppCore -> - Help.report "MISSING DEPENDENCY" (Just "elm.json") - "I need to see an \"elm/core\" dependency your elm.json file. The default imports\ - \ of `List` and `Maybe` do not work without it." - [ D.reflow $ - "If you modified your elm.json by hand, try to change it back! And if you are\ - \ having trouble getting back to a working elm.json, it may be easier to delete it\ - \ and use `elm init` to start fresh." - ] - - OutlineNoAppJson -> - Help.report "MISSING DEPENDENCY" (Just "elm.json") - "I need to see an \"elm/json\" dependency your elm.json file. It helps me handle\ - \ flags and ports." - [ D.reflow $ - "If you modified your elm.json by hand, try to change it back! And if you are\ - \ having trouble getting back to a working elm.json, it may be easier to delete it\ - \ and use `elm init` to start fresh." - ] - - -toOutlineProblemReport :: FilePath -> Code.Source -> Json.Context -> A.Region -> OutlineProblem -> Help.Report -toOutlineProblemReport path source _ region problem = - let - toHighlight row col = - Just $ A.Region (A.Position row col) (A.Position row col) - - toSnippet title highlight pair = - Help.jsonReport title (Just path) $ - Code.toSnippet source region highlight pair - in - case problem of - OP_BadType -> - toSnippet "UNEXPECTED TYPE" Nothing - ( D.reflow $ - "I got stuck while reading your elm.json file. I cannot handle a \"type\" like this:" - , D.fillSep - ["Try","changing","the","\"type\"","to" - ,D.green "\"application\"","or",D.green "\"package\"","instead." - ] - ) - - OP_BadPkgName row col -> - toSnippet "INVALID PACKAGE NAME" (toHighlight row col) - ( D.reflow $ - "I got stuck while reading your elm.json file. I ran into trouble with the package name:" - , D.stack - [ D.fillSep - ["Package","names","are","always","written","as" - ,D.green "\"author/project\"" - ,"so","I","am","expecting","to","see","something","like:" - ] - , D.dullyellow $ D.indent 4 $ D.vcat $ - [ "\"mdgriffith/elm-ui\"" - , "\"w0rm/elm-physics\"" - , "\"Microsoft/elm-json-tree-view\"" - , "\"FordLabs/elm-star-rating\"" - , "\"1602/json-schema\"" - ] - , D.reflow - "The author name should match your GitHub name exactly, and the project name\ - \ needs to follow these rules:" - , D.indent 4 $ D.vcat $ - [ "+--------------------------------------+-----------+-----------+" - , "| RULE | BAD | GOOD |" - , "+--------------------------------------+-----------+-----------+" - , "| only lower case, digits, and hyphens | elm-HTTP | elm-http |" - , "| no leading digits | 3D | elm-3d |" - , "| no non-ASCII characters | elm-bjørn | elm-bear |" - , "| no underscores | elm_ui | elm-ui |" - , "| no double hyphens | elm--hash | elm-hash |" - , "| no starting or ending hyphen | -elm-tar- | elm-tar |" - , "+--------------------------------------+-----------+-----------+" - ] - , D.toSimpleNote $ - "These rules only apply to the project name, so you should never need\ - \ to change your GitHub name!" - ] - ) - - OP_BadVersion row col -> - toSnippet "PROBLEM WITH VERSION" (toHighlight row col) - ( D.reflow $ - "I got stuck while reading your elm.json file. I was expecting a version number here:" - , D.fillSep - ["I","need","something","like",D.green "\"1.0.0\"","or",D.green "\"2.0.4\"" - ,"that","explicitly","states","all","three","numbers!" - ] - ) - - OP_BadConstraint constraintError -> - case constraintError of - C.BadFormat row col -> - toSnippet "PROBLEM WITH CONSTRAINT" (toHighlight row col) - ( D.reflow $ - "I got stuck while reading your elm.json file. I do not understand this version constraint:" - , D.stack - [ D.fillSep - ["I","need","something","like",D.green "\"1.0.0 <= v < 2.0.0\"" - ,"that","explicitly","lists","the","lower","and","upper","bounds." - ] - , D.toSimpleNote $ - "The spaces in there are required! Taking them out will confuse me. Adding\ - \ extra spaces confuses me too. I recommend starting with a valid example\ - \ and just changing the version numbers." - ] - ) - - C.InvalidRange before after -> - if before == after then - toSnippet "PROBLEM WITH CONSTRAINT" Nothing - ( D.reflow $ - "I got stuck while reading your elm.json file. I ran into an invalid version constraint:" - , D.fillSep - ["Elm","checks","that","all","package","APIs","follow","semantic","versioning," - ,"so","it","is","best","to","use","wide","constraints.","I","recommend" - ,D.green $ "\"" <> D.fromVersion before <> " <= v < " <> D.fromVersion (V.bumpMajor after) <> "\"" - ,"since","it","is","guaranteed","that","breaking","API","changes","cannot" - ,"happen","in","any","of","the","versions","in","that","range." - ] - ) - - else - toSnippet "PROBLEM WITH CONSTRAINT" Nothing - ( D.reflow $ - "I got stuck while reading your elm.json file. I ran into an invalid version constraint:" - , D.fillSep - ["Maybe","you","want","something","like" - ,D.green $ "\"" <> D.fromVersion before <> " <= v < " <> D.fromVersion (V.bumpMajor before) <> "\"" - ,"instead?","Elm","checks","that","all","package","APIs","follow","semantic" - ,"versioning,","so","it","is","guaranteed","that","breaking","API","changes" - ,"cannot","happen","in","any","of","the","versions","in","that","range." - ] - ) - - OP_BadModuleName row col -> - toSnippet "PROBLEM WITH MODULE NAME" (toHighlight row col) - ( D.reflow $ - "I got stuck while reading your elm.json file. I was expecting a module name here:" - , D.fillSep - ["I","need","something","like",D.green "\"Html.Events\"" - ,"or",D.green "\"Browser.Navigation\"" - ,"where","each","segment","starts","with","a","capital" - ,"letter","and","the","segments","are","separated","by","dots." - ] - ) - - OP_BadModuleHeaderTooLong -> - toSnippet "HEADER TOO LONG" Nothing - ( D.reflow $ - "I got stuck while reading your elm.json file. This section header is too long:" - , D.stack - [ D.fillSep - ["I","need","it","to","be" - ,D.green "under",D.green "20",D.green "bytes" - ,"so","it","renders","nicely","on","the","package","website!" - ] - , D.toSimpleNote - "I count the length in bytes, so using non-ASCII characters costs extra.\ - \ Please report your case at https://github.com/elm/compiler/issues if this seems\ - \ overly restrictive for your needs." - ] - ) - - OP_BadDependencyName row col -> - toSnippet "PROBLEM WITH DEPENDENCY NAME" (toHighlight row col) - ( D.reflow $ - "I got stuck while reading your elm.json file. There is something wrong with this dependency name:" - , D.stack - [ D.fillSep - ["Package","names","always","include","the","name","of","the","author," - ,"so","I","am","expecting","to","see","dependencies","like" - ,D.dullyellow "\"mdgriffith/elm-ui\"","and" - ,D.dullyellow "\"Microsoft/elm-json-tree-view\"" <> "." - ] - , D.fillSep $ - ["I","generally","recommend","finding","the","package","you","want","on" - ,"the","package","website,","and","installing","it","with","the" - ,D.green "elm install","command!" - ] - ] - ) - - OP_BadLicense _ suggestions -> - toSnippet "UNKNOWN LICENSE" Nothing - ( D.reflow $ - "I got stuck while reading your elm.json file. I do not know about this type of license:" - , - D.stack - [ D.fillSep - ["Elm","packages","generally","use" - ,D.green "\"BSD-3-Clause\"","or",D.green "\"MIT\"" <> "," - ,"but","I","accept","any","OSI","approved","SPDX","license." - ,"Here","some","that","seem","close","to","what","you","wrote:" - ] - , D.indent 4 $ D.dullyellow $ D.vcat $ map (D.fromChars . Json.toChars) suggestions - , D.reflow $ - "Check out https://spdx.org/licenses/ for the full list of options." - ] - ) - - OP_BadSummaryTooLong -> - toSnippet "SUMMARY TOO LONG" Nothing - ( D.reflow $ - "I got stuck while reading your elm.json file. Your \"summary\" is too long:" - , D.stack - [ D.fillSep - ["I","need","it","to","be" - ,D.green "under",D.green "80",D.green "bytes" - ,"so","it","renders","nicely","on","the","package","website!" - ] - , D.toSimpleNote - "I count the length in bytes, so using non-ASCII characters costs extra.\ - \ Please report your case at https://github.com/elm/compiler/issues if this seems\ - \ overly restrictive for your needs." - ] - ) - - OP_NoSrcDirs -> - toSnippet "NO SOURCE DIRECTORIES" Nothing - ( D.reflow $ - "I got stuck while reading your elm.json file. You do not have any \"source-directories\" listed here:" - , D.fillSep - ["I","need","something","like",D.green "[\"src\"]" - ,"so","I","know","where","to","look","for","your","modules!" - ] - ) - - - --- DETAILS - - -data Details - = DetailsNoSolution - | DetailsNoOfflineSolution - | DetailsSolverProblem Solver - | DetailsBadElmInPkg C.Constraint - | DetailsBadElmInAppOutline V.Version - | DetailsHandEditedDependencies - | DetailsBadOutline Outline - | DetailsCannotGetRegistry RegistryProblem - | DetailsBadDeps FilePath [DetailsBadDep] - - -data DetailsBadDep - = BD_BadDownload Pkg.Name V.Version PackageProblem - | BD_BadBuild Pkg.Name V.Version (Map.Map Pkg.Name V.Version) - - -toDetailsReport :: Details -> Help.Report -toDetailsReport details = - case details of - DetailsNoSolution -> - Help.report "INCOMPATIBLE DEPENDENCIES" (Just "elm.json") - "The dependencies in your elm.json are not compatible." - [ D.fillSep - ["Did","you","change","them","by","hand?","Try","to","change","it","back!" - ,"It","is","much","more","reliable","to","add","dependencies","with",D.green "elm install" - ,"or","the","dependency","management","tool","in",D.green "elm reactor" <> "." - ] - , D.reflow $ - "Please ask for help on the community forums if you try those paths and are still\ - \ having problems!" - ] - - DetailsNoOfflineSolution -> - Help.report "TROUBLE VERIFYING DEPENDENCIES" (Just "elm.json") - "I could not connect to https://package.elm-lang.org to get the latest list of\ - \ packages, and I was unable to verify your dependencies with the information I\ - \ have cached locally." - [ D.reflow $ - "Are you able to connect to the internet? These dependencies may work once you\ - \ get access to the registry!" - , D.toFancyNote - ["If","you","changed","your","dependencies","by","hand,","try","to","change","them","back!" - ,"It","is","much","more","reliable","to","add","dependencies","with",D.green "elm install" - ,"or","the","dependency","management","tool","in",D.green "elm reactor" <> "." - ] - ] - - DetailsSolverProblem solver -> - toSolverReport solver - - DetailsBadElmInPkg constraint -> - Help.report "ELM VERSION MISMATCH" (Just "elm.json") - "Your elm.json says this package needs a version of Elm in this range:" - [ D.indent 4 $ D.dullyellow $ D.fromChars $ C.toChars constraint - , D.fillSep - [ "But", "you", "are", "using", "Elm" - , D.red (D.fromVersion V.compiler) - , "right", "now." - ] - ] - - DetailsBadElmInAppOutline version -> - Help.report "ELM VERSION MISMATCH" (Just "elm.json") - "Your elm.json says this application needs a different version of Elm." - [ D.fillSep - [ "It", "requires" - , D.green (D.fromVersion version) <> "," - , "but", "you", "are", "using" - , D.red (D.fromVersion V.compiler) - , "right", "now." - ] - ] - - DetailsHandEditedDependencies -> - Help.report "ERROR IN DEPENDENCIES" (Just "elm.json") - "It looks like the dependencies elm.json in were edited by hand (or by a 3rd\ - \ party tool) leaving them in an invalid state." - [ D.fillSep - ["Try","to","change","them","back","to","what","they","were","before!" - ,"It","is","much","more","reliable","to","add","dependencies","with",D.green "elm install" - ,"or","the","dependency","management","tool","in",D.green "elm reactor" <> "." - ] - , D.reflow $ - "Please ask for help on the community forums if you try those paths and are still\ - \ having problems!" - ] - - DetailsBadOutline outline -> - toOutlineReport outline - - DetailsCannotGetRegistry problem -> - toRegistryProblemReport "PROBLEM LOADING PACKAGE LIST" problem $ - "I need the list of published packages to verify your dependencies" - - DetailsBadDeps cacheDir deps -> - case List.sortOn toBadDepRank deps of - [] -> - Help.report "PROBLEM BUILDING DEPENDENCIES" Nothing - "I am not sure what is going wrong though." - [ D.reflow $ - "I would try deleting the " ++ cacheDir ++ " and elm-stuff/ directories, then\ - \ trying to build again. That will work if some cached files got corrupted\ - \ somehow." - , D.reflow $ - "If that does not work, go to https://elm-lang.org/community and ask for\ - \ help. This is a weird case!" - ] - - d:_ -> - case d of - BD_BadDownload pkg vsn packageProblem -> - toPackageProblemReport pkg vsn packageProblem - - BD_BadBuild pkg vsn fingerprint -> - Help.report "PROBLEM BUILDING DEPENDENCIES" Nothing - "I ran into a compilation error when trying to build the following package:" - [ D.indent 4 $ D.red $ D.fromChars $ Pkg.toChars pkg ++ " " ++ V.toChars vsn - , D.reflow $ - "This probably means it has package constraints that are too wide. It may be\ - \ possible to tweak your elm.json to avoid the root problem as a stopgap. Head\ - \ over to https://elm-lang.org/community to get help figuring out how to take\ - \ this path!" - , D.toSimpleNote $ - "To help with the root problem, please report this to the package author along\ - \ with the following information:" - , D.indent 4 $ D.vcat $ - map (\(p,v) -> D.fromChars $ Pkg.toChars p ++ " " ++ V.toChars v) $ - Map.toList fingerprint - , D.reflow $ - "If you want to help out even more, try building the package locally. That should\ - \ give you much more specific information about why this package is failing to\ - \ build, which will in turn make it easier for the package author to fix it!" - ] - - -toBadDepRank :: DetailsBadDep -> Int -- lower is better -toBadDepRank badDep = - case badDep of - BD_BadDownload _ _ _ -> 0 - BD_BadBuild _ _ _ -> 1 - - - --- PACKAGE PROBLEM - - -data PackageProblem - = PP_BadEndpointRequest Http.Error - | PP_BadEndpointContent String - | PP_BadArchiveRequest Http.Error - | PP_BadArchiveContent String - | PP_BadArchiveHash String String String - - -toPackageProblemReport :: Pkg.Name -> V.Version -> PackageProblem -> Help.Report -toPackageProblemReport pkg vsn problem = - let - thePackage = - Pkg.toChars pkg ++ " " ++ V.toChars vsn - in - case problem of - PP_BadEndpointRequest httpError -> - toHttpErrorReport "PROBLEM DOWNLOADING PACKAGE" httpError $ - "I need to find the latest download link for " ++ thePackage - - PP_BadEndpointContent url -> - Help.report "PROBLEM DOWNLOADING PACKAGE" Nothing - ( - "I need to find the latest download link for " ++ thePackage ++ ", but I ran into corrupted information from:" - ) - [ D.indent 4 $ D.dullyellow $ D.fromChars url - , D.reflow $ - "Is something weird with your internet connection. We have gotten reports that\ - \ schools, businesses, airports, etc. sometimes intercept requests and add things\ - \ to the body or change its contents entirely. Could that be the problem?" - ] - - PP_BadArchiveRequest httpError -> - toHttpErrorReport "PROBLEM DOWNLOADING PACKAGE" httpError $ - "I was trying to download the source code for " ++ thePackage - - PP_BadArchiveContent url -> - Help.report "PROBLEM DOWNLOADING PACKAGE" Nothing - ( - "I downloaded the source code for " ++ thePackage ++ " from:" - ) - [ D.indent 4 $ D.dullyellow $ D.fromChars url - , D.reflow $ - "But I was unable to unzip the data. Maybe there is something weird with\ - \ your internet connection. We have gotten reports that schools, businesses,\ - \ airports, etc. sometimes intercept requests and add things to the body or\ - \ change its contents entirely. Could that be the problem?" - ] - - PP_BadArchiveHash url expectedHash actualHash -> - Help.report "CORRUPT PACKAGE DATA" Nothing - ( - "I downloaded the source code for " ++ thePackage ++ " from:" - ) - [ D.indent 4 $ D.dullyellow $ D.fromChars url - , D.reflow "But it looks like the hash of the archive has changed since publication:" - , D.vcat $ map D.fromChars $ - [ " Expected: " ++ expectedHash - , " Actual: " ++ actualHash - ] - , D.reflow $ - "This usually means that the package author moved the version\ - \ tag, so report it to them and see if that is the issue. Folks\ - \ on Elm slack can probably help as well." - ] - - - --- REGISTRY PROBLEM - - -data RegistryProblem - = RP_Http Http.Error - | RP_Data String BS.ByteString - - -toRegistryProblemReport :: String -> RegistryProblem -> String -> Help.Report -toRegistryProblemReport title problem context = - case problem of - RP_Http err -> - toHttpErrorReport title err context - - RP_Data url body -> - Help.report title Nothing (context ++ ", so I fetched:") - [ D.indent 4 $ D.dullyellow $ D.fromChars url - , D.reflow $ - "I got the data back, but it was not what I was expecting. The response\ - \ body contains " ++ show (BS.length body) ++ " bytes. Here is the " - ++ if BS.length body <= 76 then "whole thing:" else "beginning:" - , D.indent 4 $ D.dullyellow $ D.fromChars $ - if BS.length body <= 76 - then BS_UTF8.toString body - else take 73 (BS_UTF8.toString body) ++ "..." - , D.reflow $ - "Does this error keep showing up? Maybe there is something weird with your\ - \ internet connection. We have gotten reports that schools, businesses,\ - \ airports, etc. sometimes intercept requests and add things to the body\ - \ or change its contents entirely. Could that be the problem?" - ] - - -toHttpErrorReport :: String -> Http.Error -> String -> Help.Report -toHttpErrorReport title err context = - let - toHttpReport intro url details = - Help.report title Nothing intro $ - D.indent 4 (D.dullyellow (D.fromChars url)) : details - in - case err of - Http.BadUrl url reason -> - toHttpReport (context ++ ", so I wanted to fetch:") url - [ D.reflow $ "But my HTTP library is saying this is not a valid URL. It is saying:" - , D.indent 4 $ D.fromChars reason - , D.reflow $ - "This may indicate that there is some problem in the compiler, so please open an\ - \ issue at https://github.com/elm/compiler/issues listing your operating system, Elm\ - \ version, the command you ran, the terminal output, and any additional information\ - \ that might help others reproduce the error." - ] - - Http.BadHttp url httpExceptionContent -> - case httpExceptionContent of - HTTP.StatusCodeException response _ -> - let - (HTTP.Status code message) = HTTP.responseStatus response - in - toHttpReport (context ++ ", so I tried to fetch:") url - [ D.fillSep $ - ["But","it","came","back","as",D.red (D.fromInt code)] - ++ map D.fromChars (words (BS_UTF8.toString message)) - , D.reflow $ - "This may mean some online endpoint changed in an unexpected way, so if does not\ - \ seem like something on your side is causing this (e.g. firewall) please report\ - \ this to https://github.com/elm/compiler/issues with your operating system, Elm\ - \ version, the command you ran, the terminal output, and any additional information\ - \ that can help others reproduce the error!" - ] - - HTTP.TooManyRedirects responses -> - toHttpReport (context ++ ", so I tried to fetch:") url - [ D.reflow $ "But I gave up after following these " ++ show (length responses) ++ " redirects:" - , D.indent 4 $ D.vcat $ map toRedirectDoc responses - , D.reflow $ - "Is it possible that your internet connection intercepts certain requests? That\ - \ sometimes causes problems for folks in schools, businesses, airports, hotels,\ - \ and certain countries. Try asking for help locally or in a community forum!" - ] - - otherException -> - toHttpReport (context ++ ", so I tried to fetch:") url - [ D.reflow $ "But my HTTP library is giving me the following error message:" - , D.indent 4 $ D.fromChars (show otherException) - , D.reflow $ - "Are you somewhere with a slow internet connection? Or no internet?\ - \ Does the link I am trying to fetch work in your browser? Maybe the\ - \ site is down? Does your internet connection have a firewall that\ - \ blocks certain domains? It is usually something like that!" - ] - - Http.BadMystery url someException -> - toHttpReport (context ++ ", so I tried to fetch:") url - [ D.reflow $ "But I ran into something weird! I was able to extract this error message:" - , D.indent 4 $ D.fromChars (show someException) - , D.reflow $ - "Is it possible that your internet connection intercepts certain requests? That\ - \ sometimes causes problems for folks in schools, businesses, airports, hotels,\ - \ and certain countries. Try asking for help locally or in a community forum!" - ] - - -toRedirectDoc :: HTTP.Response body -> D.Doc -toRedirectDoc response = - let - (HTTP.Status code message) = HTTP.responseStatus response - in - case List.lookup HTTP.hLocation (HTTP.responseHeaders response) of - Just loc -> D.red (D.fromInt code) <> " - " <> D.fromChars (BS_UTF8.toString loc) - Nothing -> D.red (D.fromInt code) <> " - " <> D.fromChars (BS_UTF8.toString message) - - - --- MAKE - - -data Make - = MakeNoOutline - | MakeCannotOptimizeAndDebug - | MakeBadDetails Details - | MakeAppNeedsFileNames - | MakePkgNeedsExposing - | MakeMultipleFilesIntoHtml - | MakeNoMain - | MakeNonMainFilesIntoJavaScript ModuleName.Raw [ModuleName.Raw] - | MakeCannotBuild BuildProblem - | MakeBadGenerate Generate - - -makeToReport :: Make -> Help.Report -makeToReport make = - case make of - MakeNoOutline -> - Help.report "NO elm.json FILE" Nothing - "It looks like you are starting a new Elm project. Very exciting! Try running:" - [ D.indent 4 $ D.green $ "elm init" - , D.reflow $ - "It will help you get set up. It is really simple!" - ] - - MakeCannotOptimizeAndDebug -> - Help.docReport "CLASHING FLAGS" Nothing - ( D.fillSep - ["I","cannot","compile","with",D.red "--optimize","and" - ,D.red "--debug","at","the","same","time." - ] - ) - [ D.reflow - "I need to take away information to optimize things, and I need to\ - \ add information to add the debugger. It is impossible to do both\ - \ at once though! Pick just one of those flags and it should work!" - ] - - MakeBadDetails detailsProblem -> - toDetailsReport detailsProblem - - MakeAppNeedsFileNames -> - Help.report "NO INPUT" Nothing - "What should I make though? I need specific files like:" - [ D.vcat - [ D.indent 4 $ D.green "elm make src/Main.elm" - , D.indent 4 $ D.green "elm make src/This.elm src/That.elm" - ] - , D.reflow $ - "I recommend reading through https://guide.elm-lang.org for guidance on what to\ - \ actually put in those files!" - ] - - MakePkgNeedsExposing -> - Help.report "NO INPUT" Nothing - "What should I make though? I need specific files like:" - [ D.vcat - [ D.indent 4 $ D.green "elm make src/Main.elm" - , D.indent 4 $ D.green "elm make src/This.elm src/That.elm" - ] - , D.reflow $ - "You can also entries to the \"exposed-modules\" list in your elm.json file, and\ - \ I will try to compile the relevant files." - ] - - MakeMultipleFilesIntoHtml -> - Help.report "TOO MANY FILES" Nothing - ( - "When producing an HTML file, I can only handle one file." - ) - [ D.fillSep - ["Switch","to",D.dullyellow "--output=/dev/null","if","you","just","want" - ,"to","get","compile","errors.","This","skips","the","code","gen","phase," - ,"so","it","can","be","a","bit","faster","than","other","options","sometimes." - ] - , D.fillSep - ["Switch","to",D.dullyellow "--output=elm.js","if","you","want","multiple" - ,"`main`","values","available","in","a","single","JavaScript","file.","Then" - ,"you","can","make","your","own","customized","HTML","file","that","embeds" - ,"multiple","Elm","nodes.","The","generated","JavaScript","also","shares" - ,"dependencies","between","modules,","so","it","should","be","smaller","than" - ,"compiling","each","module","separately." - ] - ] - - MakeNoMain -> - Help.report "NO MAIN" Nothing - ( - "When producing an HTML file, I require that the given file has a `main` value.\ - \ That way I have something to show on screen!" - ) - [ D.reflow $ - "Try adding a `main` value to your file? Or if you just want to verify that this\ - \ module compiles, switch to --output=/dev/null to skip the code gen phase\ - \ altogether." - , D.toSimpleNote $ - "Adding a `main` value can be as brief as adding something like this:" - , D.vcat - [ D.fillSep [D.cyan "import","Html"] - , "" - , D.fillSep [D.green "main","="] - , D.indent 2 $ D.fillSep [D.cyan "Html" <> ".text",D.dullyellow "\"Hello!\""] - ] - , D.reflow $ - "From there I can create an HTML file that says \"Hello!\" on screen. I recommend\ - \ looking through https://guide.elm-lang.org for more guidance on how to fill in\ - \ the `main` value." - ] - - MakeNonMainFilesIntoJavaScript m ms -> - case ms of - [] -> - Help.report "NO MAIN" Nothing - ( - "When producing a JS file, I require that the given file has a `main` value. That\ - \ way Elm." ++ ModuleName.toChars m ++ ".init() is definitely defined in the\ - \ resulting file!" - ) - [ D.reflow $ - "Try adding a `main` value to your file? Or if you just want to verify that this\ - \ module compiles, switch to --output=/dev/null to skip the code gen phase\ - \ altogether." - , D.toSimpleNote $ - "Adding a `main` value can be as brief as adding something like this:" - , D.vcat - [ D.fillSep [D.cyan "import","Html"] - , "" - , D.fillSep [D.green "main","="] - , D.indent 2 $ D.fillSep [D.cyan "Html" <> ".text",D.dullyellow "\"Hello!\""] - ] - , D.reflow $ - "Or use https://package.elm-lang.org/packages/elm/core/latest/Platform#worker to\ - \ make a `main` with no user interface." - ] - - _:_ -> - Help.report "NO MAIN" Nothing - ( - "When producing a JS file, I require that given files all have `main` values.\ - \ That way functions like Elm." ++ ModuleName.toChars m ++ ".init() are\ - \ definitely defined in the resulting file. I am missing `main` values in:" - ) - [ D.indent 4 $ D.red $ D.vcat $ map D.fromName (m:ms) - , D.reflow $ - "Try adding a `main` value to them? Or if you just want to verify that these\ - \ modules compile, switch to --output=/dev/null to skip the code gen phase\ - \ altogether." - , D.toSimpleNote $ - "Adding a `main` value can be as brief as adding something like this:" - , D.vcat - [ D.fillSep [D.cyan "import","Html"] - , "" - , D.fillSep [D.green "main","="] - , D.indent 2 $ D.fillSep [D.cyan "Html" <> ".text",D.dullyellow "\"Hello!\""] - ] - , D.reflow $ - "Or use https://package.elm-lang.org/packages/elm/core/latest/Platform#worker to\ - \ make a `main` with no user interface." - ] - - MakeCannotBuild buildProblem -> - toBuildProblemReport buildProblem - - MakeBadGenerate generateProblem -> - toGenerateReport generateProblem - - - --- BUILD PROBLEM - - -data BuildProblem - = BuildBadModules FilePath Error.Module [Error.Module] - | BuildProjectProblem BuildProjectProblem - - -data BuildProjectProblem - = BP_PathUnknown FilePath - | BP_WithBadExtension FilePath - | BP_WithAmbiguousSrcDir FilePath FilePath FilePath - | BP_MainPathDuplicate FilePath FilePath - | BP_RootNameDuplicate ModuleName.Raw FilePath FilePath - | BP_RootNameInvalid FilePath FilePath [String] - | BP_CannotLoadDependencies - | BP_Cycle ModuleName.Raw [ModuleName.Raw] - | BP_MissingExposed (NE.List (ModuleName.Raw, Import.Problem)) - - -toBuildProblemReport :: BuildProblem -> Help.Report -toBuildProblemReport problem = - case problem of - BuildBadModules root e es -> - Help.compilerReport root e es - - BuildProjectProblem projectProblem -> - toProjectProblemReport projectProblem - - -toProjectProblemReport :: BuildProjectProblem -> Help.Report -toProjectProblemReport projectProblem = - case projectProblem of - BP_PathUnknown path -> - Help.report "FILE NOT FOUND" Nothing - "I cannot find this file:" - [ D.indent 4 $ D.red $ D.fromChars path - , D.reflow $ "Is there a typo?" - , D.toSimpleNote $ - "If you are just getting started, try working through the examples in the\ - \ official guide https://guide.elm-lang.org to get an idea of the kinds of things\ - \ that typically go in a src/Main.elm file." - ] - - BP_WithBadExtension path -> - Help.report "UNEXPECTED FILE EXTENSION" Nothing - "I can only compile Elm files (with a .elm extension) but you want me to compile:" - [ D.indent 4 $ D.red $ D.fromChars path - , D.reflow $ "Is there a typo? Can the file extension be changed?" - ] - - BP_WithAmbiguousSrcDir path srcDir1 srcDir2 -> - Help.report "CONFUSING FILE" Nothing - "I am getting confused when I try to compile this file:" - [ D.indent 4 $ D.red $ D.fromChars path - , D.reflow $ - "I always check if files appear in any of the \"source-directories\" listed in\ - \ your elm.json to see if there might be some cached information about them. That\ - \ can help me compile faster! But in this case, it looks like this file may be in\ - \ either of these directories:" - , D.indent 4 $ D.red $ D.vcat $ map D.fromChars [srcDir1,srcDir2] - , D.reflow $ - "Try to make it so no source directory contains another source directory!" - ] - - BP_MainPathDuplicate path1 path2 -> - Help.report "CONFUSING FILES" Nothing - "You are telling me to compile these two files:" - [ D.indent 4 $ D.red $ D.vcat $ map D.fromChars [ path1, path2 ] - , D.reflow $ - if path1 == path2 then - "Why are you telling me twice? Is something weird going on with a script?\ - \ I figured I would let you know about it just in case something is wrong.\ - \ Only list it once and you should be all set!" - else - "But seem to be the same file though... It makes me think something tricky is\ - \ going on with symlinks in your project, so I figured I would let you know\ - \ about it just in case. Remove one of these files from your command to get\ - \ unstuck!" - ] - - BP_RootNameDuplicate name outsidePath otherPath -> - Help.report "MODULE NAME CLASH" Nothing - "These two files are causing a module name clash:" - [ D.indent 4 $ D.red $ D.vcat $ map D.fromChars [ outsidePath, otherPath ] - , D.reflow $ - "They both say `module " ++ ModuleName.toChars name ++ " exposing (..)` up\ - \ at the top, but they cannot have the same name!" - , D.reflow $ - "Try changing to a different module name in one of them!" - ] - - BP_RootNameInvalid givenPath srcDir _ -> - Help.report "UNEXPECTED FILE NAME" Nothing - "I am having trouble with this file name:" - [ D.indent 4 $ D.red $ D.fromChars givenPath - , D.reflow $ - "I found it in your " ++ FP.addTrailingPathSeparator srcDir ++ " directory\ - \ which is good, but I expect all of the files in there to use the following\ - \ module naming convention:" - , toModuleNameConventionTable srcDir [ "Main", "HomePage", "Http.Helpers" ] - , D.reflow $ - "Notice that the names always start with capital letters! Can you make your file\ - \ use this naming convention?" - , D.toSimpleNote $ - "Having a strict naming convention like this makes it a lot easier to find\ - \ things in large projects. If you see a module imported, you know where to look\ - \ for the corresponding file every time!" - ] - - BP_CannotLoadDependencies -> - corruptCacheReport - - BP_Cycle name names -> - Help.report "IMPORT CYCLE" Nothing - "Your module imports form a cycle:" - [ D.cycle 4 name names - , D.reflow $ - "Learn more about why this is disallowed and how to break cycles here:" - ++ D.makeLink "import-cycles" - ] - - BP_MissingExposed (NE.List (name, problem) _) -> - case problem of - Import.NotFound -> - Help.report "MISSING MODULE" (Just "elm.json") - "The \"exposed-modules\" of your elm.json lists the following module:" - [ D.indent 4 $ D.red $ D.fromName name - , D.reflow $ - "But I cannot find it in your src/ directory. Is there a typo? Was it renamed?" - ] - - Import.Ambiguous _ _ pkg _ -> - Help.report "AMBIGUOUS MODULE NAME" (Just "elm.json") - "The \"exposed-modules\" of your elm.json lists the following module:" - [ D.indent 4 $ D.red $ D.fromName name - , D.reflow $ - "But a module from " ++ Pkg.toChars pkg ++ " already uses that name. Try\ - \ choosing a different name for your local file." - ] - - Import.AmbiguousLocal path1 path2 paths -> - Help.report "AMBIGUOUS MODULE NAME" (Just "elm.json") - "The \"exposed-modules\" of your elm.json lists the following module:" - [ D.indent 4 $ D.red $ D.fromName name - , D.reflow $ - "But I found multiple files with that name:" - , D.dullyellow $ D.indent 4 $ D.vcat $ - map D.fromChars (path1:path2:paths) - , D.reflow $ - "Change the module names to be distinct!" - ] - - Import.AmbiguousForeign _ _ _ -> - Help.report "MISSING MODULE" (Just "elm.json") - "The \"exposed-modules\" of your elm.json lists the following module:" - [ D.indent 4 $ D.red $ D.fromName name - , D.reflow $ - "But I cannot find it in your src/ directory. Is there a typo? Was it renamed?" - , D.toSimpleNote $ - "It is not possible to \"re-export\" modules from other packages. You can only\ - \ expose modules that you define in your own code." - ] - - -toModuleNameConventionTable :: FilePath -> [String] -> D.Doc -toModuleNameConventionTable srcDir names = - let - toPair name = - ( name - , srcDir map (\c -> if c == '.' then FP.pathSeparator else c) name <.> "elm" - ) - - namePairs = map toPair names - nameWidth = maximum (11 : map (length . fst) namePairs) - pathWidth = maximum ( 9 : map (length . snd) namePairs) - - padded width str = - str ++ replicate (width - length str) ' ' - - toRow (name, path) = - D.fromChars $ - "| " ++ padded nameWidth name ++ " | " ++ padded pathWidth path ++ " |" - - bar = - D.fromChars $ - "+-" ++ replicate nameWidth '-' ++ "-+-" ++ replicate pathWidth '-' ++ "-+" - in - D.indent 4 $ D.vcat $ - [ bar, toRow ("Module Name", "File Path"), bar ] ++ map toRow namePairs ++ [ bar ] - - - --- GENERATE - - -data Generate - = GenerateCannotLoadArtifacts - | GenerateCannotOptimizeDebugValues ModuleName.Raw [ModuleName.Raw] - - -toGenerateReport :: Generate -> Help.Report -toGenerateReport problem = - case problem of - GenerateCannotLoadArtifacts -> - corruptCacheReport - - GenerateCannotOptimizeDebugValues m ms -> - Help.report "DEBUG REMNANTS" Nothing - "There are uses of the `Debug` module in the following modules:" - [ D.indent 4 $ D.red $ D.vcat $ map (D.fromChars . ModuleName.toChars) (m:ms) - , D.reflow "But the --optimize flag only works if all `Debug` functions are removed!" - , D.toSimpleNote $ - "The issue is that --optimize strips out info needed by `Debug` functions.\ - \ Here are two examples:" - , D.indent 4 $ D.reflow $ - "(1) It shortens record field names. This makes the generated JavaScript is\ - \ smaller, but `Debug.toString` cannot know the real field names anymore." - , D.indent 4 $ D.reflow $ - "(2) Values like `type Height = Height Float` are unboxed. This reduces\ - \ allocation, but it also means that `Debug.toString` cannot tell if it is\ - \ looking at a `Height` or `Float` value." - , D.reflow $ - "There are a few other cases like that, and it will be much worse once we start\ - \ inlining code. That optimization could move `Debug.log` and `Debug.todo` calls,\ - \ resulting in unpredictable behavior. I hope that clarifies why this restriction\ - \ exists!" - ] - - - --- CORRUPT CACHE - - -corruptCacheReport :: Help.Report -corruptCacheReport = - Help.report "CORRUPT CACHE" Nothing - "It looks like some of the information cached in elm-stuff/ has been corrupted." - [ D.reflow $ - "Try deleting your elm-stuff/ directory to get unstuck." - , D.toSimpleNote $ - "This almost certainly means that a 3rd party tool (or editor plugin) is\ - \ causing problems your the elm-stuff/ directory. Try disabling 3rd party tools\ - \ one by one until you figure out which it is!" - ] - - - --- REACTOR - - -data Reactor - = ReactorNoOutline - | ReactorBadDetails Details - | ReactorBadBuild BuildProblem - | ReactorBadGenerate Generate - - -reactorToReport :: Reactor -> Help.Report -reactorToReport problem = - case problem of - ReactorNoOutline -> - Help.report "NEW PROJECT?" Nothing - "Are you trying to start a new project? Try this command in the terminal:" - [ D.indent 4 $ D.green "elm init" - , D.reflow "It will help you get started!" - ] - - ReactorBadDetails details -> - toDetailsReport details - - ReactorBadBuild buildProblem -> - toBuildProblemReport buildProblem - - ReactorBadGenerate generate -> - toGenerateReport generate - - - --- REPL - - -data Repl - = ReplBadDetails Details - | ReplBadInput BS.ByteString Error.Error - | ReplBadLocalDeps FilePath Error.Module [Error.Module] - | ReplProjectProblem BuildProjectProblem - | ReplBadGenerate Generate - | ReplBadCache - | ReplBlocked - - -replToReport :: Repl -> Help.Report -replToReport problem = - case problem of - ReplBadDetails details -> - toDetailsReport details - - ReplBadInput source err -> - Help.compilerReport "/" (Error.Module N.replModule "REPL" File.zeroTime source err) [] - - ReplBadLocalDeps root e es -> - Help.compilerReport root e es - - ReplProjectProblem projectProblem -> - toProjectProblemReport projectProblem - - ReplBadGenerate generate -> - toGenerateReport generate - - ReplBadCache -> - corruptCacheReport - - ReplBlocked -> - corruptCacheReport diff --git a/builder/src/Reporting/Exit/Help.hs b/builder/src/Reporting/Exit/Help.hs deleted file mode 100644 index 8e08698f26..0000000000 --- a/builder/src/Reporting/Exit/Help.hs +++ /dev/null @@ -1,136 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module Reporting.Exit.Help - ( Report - , report - , docReport - , jsonReport - , compilerReport - , reportToDoc - , reportToJson - , toString - , toStdout - , toStderr - ) - where - - -import GHC.IO.Handle (hIsTerminalDevice) -import System.IO (Handle, hPutStr, stderr, stdout) - -import qualified Json.Encode as E -import Json.Encode ((==>)) -import Reporting.Doc ((<+>)) -import qualified Reporting.Doc as D -import qualified Reporting.Error as Error - - - --- REPORT - - -data Report - = CompilerReport FilePath Error.Module [Error.Module] - | Report - { _title :: String - , _path :: Maybe FilePath - , _message :: D.Doc - } - - -report :: String -> Maybe FilePath -> String -> [D.Doc] -> Report -report title path startString others = - Report title path $ D.stack (D.reflow startString:others) - - -docReport :: String -> Maybe FilePath -> D.Doc -> [D.Doc] -> Report -docReport title path startDoc others = - Report title path $ D.stack (startDoc:others) - - -jsonReport :: String -> Maybe FilePath -> D.Doc -> Report -jsonReport = - Report - - -compilerReport :: FilePath -> Error.Module -> [Error.Module] -> Report -compilerReport = - CompilerReport - - - --- TO DOC - - -reportToDoc :: Report -> D.Doc -reportToDoc report_ = - case report_ of - CompilerReport root e es -> - Error.toDoc root e es - - Report title maybePath message -> - let - makeDashes n = - replicate (max 1 (80 - n)) '-' - - errorBarEnd = - case maybePath of - Nothing -> - makeDashes (4 + length title) - - Just path -> - makeDashes (5 + length title + length path) ++ " " ++ path - - errorBar = - D.dullcyan $ - "--" <+> D.fromChars title <+> D.fromChars errorBarEnd - in - D.stack [errorBar, message, ""] - - - --- TO JSON - - -reportToJson :: Report -> E.Value -reportToJson report_ = - case report_ of - CompilerReport _ e es -> - E.object - [ "type" ==> E.chars "compile-errors" - , "errors" ==> E.list Error.toJson (e:es) - ] - - Report title maybePath message -> - E.object - [ "type" ==> E.chars "error" - , "path" ==> maybe E.null E.chars maybePath - , "title" ==> E.chars title - , "message" ==> D.encode message - ] - - - --- OUTPUT - - -toString :: D.Doc -> String -toString = - D.toString - - -toStdout :: D.Doc -> IO () -toStdout doc = - toHandle stdout doc - - -toStderr :: D.Doc -> IO () -toStderr doc = - toHandle stderr doc - - -toHandle :: Handle -> D.Doc -> IO () -toHandle handle doc = - do isTerminal <- hIsTerminalDevice handle - if isTerminal - then D.toAnsi handle doc - else hPutStr handle (toString doc) diff --git a/builder/src/Reporting/Task.hs b/builder/src/Reporting/Task.hs deleted file mode 100644 index 678576b1ae..0000000000 --- a/builder/src/Reporting/Task.hs +++ /dev/null @@ -1,114 +0,0 @@ -{-# LANGUAGE Rank2Types #-} -module Reporting.Task - ( Task - , run - , throw - , mapError - -- - , io - , mio - , eio - ) - where - - - --- TASKS - - -newtype Task x a = - Task - ( - forall result. (a -> IO result) -> (x -> IO result) -> IO result - ) - - -run :: Task x a -> IO (Either x a) -run (Task task) = - task (return . Right) (return . Left) - - -throw :: x -> Task x a -throw x = - Task $ \_ err -> err x - - -mapError :: (x -> y) -> Task x a -> Task y a -mapError func (Task task) = - Task $ \ok err -> - task ok (err . func) - - - --- IO - - -{-# INLINE io #-} -io :: IO a -> Task x a -io work = - Task $ \ok _ -> work >>= ok - - -mio :: x -> IO (Maybe a) -> Task x a -mio x work = - Task $ \ok err -> - do result <- work - case result of - Just a -> ok a - Nothing -> err x - - -eio :: (x -> y) -> IO (Either x a) -> Task y a -eio func work = - Task $ \ok err -> - do result <- work - case result of - Right a -> ok a - Left x -> err (func x) - - - --- INSTANCES - - -instance Functor (Task x) where - {-# INLINE fmap #-} - fmap func (Task taskA) = - Task $ \ok err -> - let - okA arg = ok (func arg) - in - taskA okA err - - -instance Applicative (Task x) where - {-# INLINE pure #-} - pure a = - Task $ \ok _ -> ok a - - {-# INLINE (<*>) #-} - (<*>) (Task taskFunc) (Task taskArg) = - Task $ \ok err -> - let - okFunc func = - let - okArg arg = ok (func arg) - in - taskArg okArg err - in - taskFunc okFunc err - - -instance Monad (Task x) where - {-# INLINE return #-} - return = pure - - {-# INLINE (>>=) #-} - (>>=) (Task taskA) callback = - Task $ \ok err -> - let - okA a = - case callback a of - Task taskB -> taskB ok err - in - taskA okA err diff --git a/builder/src/Stuff.hs b/builder/src/Stuff.hs deleted file mode 100644 index 4fa25e4f41..0000000000 --- a/builder/src/Stuff.hs +++ /dev/null @@ -1,179 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -module Stuff - ( details - , interfaces - , objects - , prepublishDir - , elmi - , elmo - , temp - , findRoot - , withRootLock - , withRegistryLock - , PackageCache - , getPackageCache - , registry - , package - , getReplCache - , getElmHome - ) - where - - -import qualified System.Directory as Dir -import qualified System.Environment as Env -import qualified System.FileLock as Lock -import qualified System.FilePath as FP -import System.FilePath ((), (<.>)) - -import qualified Elm.ModuleName as ModuleName -import qualified Elm.Package as Pkg -import qualified Elm.Version as V - - - --- PATHS - - -stuff :: FilePath -> FilePath -stuff root = - root "elm-stuff" compilerVersion - - -details :: FilePath -> FilePath -details root = - stuff root "d.dat" - - -interfaces :: FilePath -> FilePath -interfaces root = - stuff root "i.dat" - - -objects :: FilePath -> FilePath -objects root = - stuff root "o.dat" - - -prepublishDir :: FilePath -> FilePath -prepublishDir root = - stuff root "prepublish" - - -compilerVersion :: FilePath -compilerVersion = - V.toChars V.compiler - - - --- ELMI and ELMO - - -elmi :: FilePath -> ModuleName.Raw -> FilePath -elmi root name = - toArtifactPath root name "elmi" - - -elmo :: FilePath -> ModuleName.Raw -> FilePath -elmo root name = - toArtifactPath root name "elmo" - - -toArtifactPath :: FilePath -> ModuleName.Raw -> String -> FilePath -toArtifactPath root name ext = - stuff root ModuleName.toHyphenPath name <.> ext - - - --- TEMP - - -temp :: FilePath -> String -> FilePath -temp root ext = - stuff root "temp" <.> ext - - - --- ROOT - - -findRoot :: IO (Maybe FilePath) -findRoot = - do dir <- Dir.getCurrentDirectory - findRootHelp (FP.splitDirectories dir) - - -findRootHelp :: [String] -> IO (Maybe FilePath) -findRootHelp dirs = - case dirs of - [] -> - return Nothing - - _:_ -> - do exists <- Dir.doesFileExist (FP.joinPath dirs "elm.json") - if exists - then return (Just (FP.joinPath dirs)) - else findRootHelp (init dirs) - - - --- LOCKS - - -withRootLock :: FilePath -> IO a -> IO a -withRootLock root work = - do let dir = stuff root - Dir.createDirectoryIfMissing True dir - Lock.withFileLock (dir "lock") Lock.Exclusive (\_ -> work) - - -withRegistryLock :: PackageCache -> IO a -> IO a -withRegistryLock (PackageCache dir) work = - Lock.withFileLock (dir "lock") Lock.Exclusive (\_ -> work) - - - --- PACKAGE CACHES - - -newtype PackageCache = PackageCache FilePath - - -getPackageCache :: IO PackageCache -getPackageCache = - PackageCache <$> getCacheDir "packages" - - -registry :: PackageCache -> FilePath -registry (PackageCache dir) = - dir "registry.dat" - - -package :: PackageCache -> Pkg.Name -> V.Version -> FilePath -package (PackageCache dir) name version = - dir Pkg.toFilePath name V.toChars version - - - --- CACHE - - -getReplCache :: IO FilePath -getReplCache = - getCacheDir "repl" - - -getCacheDir :: FilePath -> IO FilePath -getCacheDir projectName = - do home <- getElmHome - let root = home compilerVersion projectName - Dir.createDirectoryIfMissing True root - return root - - -getElmHome :: IO FilePath -getElmHome = - do maybeCustomHome <- Env.lookupEnv "ELM_HOME" - case maybeCustomHome of - Just customHome -> return customHome - Nothing -> Dir.getAppUserDataDirectory "elm" diff --git a/cabal.config b/cabal.config deleted file mode 100644 index ea8f1197ac..0000000000 --- a/cabal.config +++ /dev/null @@ -1,2 +0,0 @@ -profiling: False -library-profiling: True diff --git a/compiler/src/AST/Canonical.hs b/compiler/src/AST/Canonical.hs deleted file mode 100644 index 78a335f665..0000000000 --- a/compiler/src/AST/Canonical.hs +++ /dev/null @@ -1,401 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE OverloadedStrings #-} -module AST.Canonical - ( Expr, Expr_(..) - , CaseBranch(..) - , FieldUpdate(..) - , CtorOpts(..) - -- definitions - , Def(..) - , Decls(..) - -- patterns - , Pattern, Pattern_(..) - , PatternCtorArg(..) - -- types - , Annotation(..) - , Type(..) - , AliasType(..) - , FieldType(..) - , fieldsToList - -- modules - , Module(..) - , Alias(..) - , Binop(..) - , Union(..) - , Ctor(..) - , Exports(..) - , Export(..) - , Effects(..) - , Port(..) - , Manager(..) - ) - where - -{- Creating a canonical AST means finding the home module for all variables. -So if you have L.map, you need to figure out that it is from the elm/core -package in the List module. - -In later phases (e.g. type inference, exhaustiveness checking, optimization) -you need to look up additional info from these modules. What is the type? -What are the alternative type constructors? These lookups can be quite costly, -especially in type inference. To reduce costs the canonicalization phase -caches info needed in later phases. This means we no longer build large -dictionaries of metadata with O(log(n)) lookups in those phases. Instead -there is an O(1) read of an existing field! I have tried to mark all -cached data with comments like: - --- CACHE for exhaustiveness --- CACHE for inference - -So it is clear why the data is kept around. --} - - -import Control.Monad (liftM, liftM2, liftM3, liftM4, replicateM) -import Data.Binary -import qualified Data.List as List -import qualified Data.Map as Map -import Data.Name (Name) - -import qualified AST.Source as Src -import qualified AST.Utils.Binop as Binop -import qualified AST.Utils.Shader as Shader -import qualified Data.Index as Index -import qualified Elm.Float as EF -import qualified Elm.ModuleName as ModuleName -import qualified Elm.String as ES -import qualified Reporting.Annotation as A - - - --- EXPRESSIONS - - -type Expr = - A.Located Expr_ - - --- CACHE Annotations for type inference -data Expr_ - = VarLocal Name - | VarTopLevel ModuleName.Canonical Name - | VarKernel Name Name - | VarForeign ModuleName.Canonical Name Annotation - | VarCtor CtorOpts ModuleName.Canonical Name Index.ZeroBased Annotation - | VarDebug ModuleName.Canonical Name Annotation - | VarOperator Name ModuleName.Canonical Name Annotation -- CACHE real name for optimization - | Chr ES.String - | Str ES.String - | Int Int - | Float EF.Float - | List [Expr] - | Negate Expr - | Binop Name ModuleName.Canonical Name Annotation Expr Expr -- CACHE real name for optimization - | Lambda [Pattern] Expr - | Call Expr [Expr] - | If [(Expr, Expr)] Expr - | Let Def Expr - | LetRec [Def] Expr - | LetDestruct Pattern Expr Expr - | Case Expr [CaseBranch] - | Accessor Name - | Access Expr (A.Located Name) - | Update Name Expr (Map.Map Name FieldUpdate) - | Record (Map.Map Name Expr) - | Unit - | Tuple Expr Expr (Maybe Expr) - | Shader Shader.Source Shader.Types - - -data CaseBranch = - CaseBranch Pattern Expr - - -data FieldUpdate = - FieldUpdate A.Region Expr - - - --- DEFS - - -data Def - = Def (A.Located Name) [Pattern] Expr - | TypedDef (A.Located Name) FreeVars [(Pattern, Type)] Expr Type - - - --- DECLARATIONS - - -data Decls - = Declare Def Decls - | DeclareRec Def [Def] Decls - | SaveTheEnvironment - - - --- PATTERNS - - -type Pattern = - A.Located Pattern_ - - -data Pattern_ - = PAnything - | PVar Name - | PRecord [Name] - | PAlias Pattern Name - | PUnit - | PTuple Pattern Pattern (Maybe Pattern) - | PList [Pattern] - | PCons Pattern Pattern - | PBool Union Bool - | PChr ES.String - | PStr ES.String - | PInt Int - | PCtor - { _p_home :: ModuleName.Canonical - , _p_type :: Name - , _p_union :: Union - , _p_name :: Name - , _p_index :: Index.ZeroBased - , _p_args :: [PatternCtorArg] - } - -- CACHE _p_home, _p_type, and _p_vars for type inference - -- CACHE _p_index to replace _p_name in PROD code gen - -- CACHE _p_opts to allocate less in PROD code gen - -- CACHE _p_alts and _p_numAlts for exhaustiveness checker - - -data PatternCtorArg = - PatternCtorArg - { _index :: Index.ZeroBased -- CACHE for destructors/errors - , _type :: Type -- CACHE for type inference - , _arg :: Pattern - } - - - --- TYPES - - -data Annotation = Forall FreeVars Type - deriving (Eq) - - -type FreeVars = Map.Map Name () - - -data Type - = TLambda Type Type - | TVar Name - | TType ModuleName.Canonical Name [Type] - | TRecord (Map.Map Name FieldType) (Maybe Name) - | TUnit - | TTuple Type Type (Maybe Type) - | TAlias ModuleName.Canonical Name [(Name, Type)] AliasType - deriving (Eq) - - -data AliasType - = Holey Type - | Filled Type - deriving (Eq) - - -data FieldType = FieldType {-# UNPACK #-} !Word16 Type - deriving (Eq) - - --- NOTE: The Word16 marks the source order, but it may not be available --- for every canonical type. For example, if the canonical type is inferred --- the orders will all be zeros. --- -fieldsToList :: Map.Map Name FieldType -> [(Name, Type)] -fieldsToList fields = - let - getIndex (_, FieldType index _) = - index - - dropIndex (name, FieldType _ tipe) = - (name, tipe) - in - map dropIndex (List.sortOn getIndex (Map.toList fields)) - - - --- MODULES - - -data Module = - Module - { _name :: ModuleName.Canonical - , _exports :: Exports - , _docs :: Src.Docs - , _decls :: Decls - , _unions :: Map.Map Name Union - , _aliases :: Map.Map Name Alias - , _binops :: Map.Map Name Binop - , _effects :: Effects - } - - -data Alias = Alias [Name] Type - deriving (Eq) - - -data Binop = Binop_ Binop.Associativity Binop.Precedence Name - deriving (Eq) - - -data Union = - Union - { _u_vars :: [Name] - , _u_alts :: [Ctor] - , _u_numAlts :: Int -- CACHE numAlts for exhaustiveness checking - , _u_opts :: CtorOpts -- CACHE which optimizations are available - } - deriving (Eq) - - -data CtorOpts - = Normal - | Enum - | Unbox - deriving (Eq, Ord) - - -data Ctor = Ctor Name Index.ZeroBased Int [Type] -- CACHE length args - deriving (Eq) - - - --- EXPORTS - - -data Exports - = ExportEverything A.Region - | Export (Map.Map Name (A.Located Export)) - - -data Export - = ExportValue - | ExportBinop - | ExportAlias - | ExportUnionOpen - | ExportUnionClosed - | ExportPort - - - --- EFFECTS - - -data Effects - = NoEffects - | Ports (Map.Map Name Port) - | Manager A.Region A.Region A.Region Manager - - -data Port - = Incoming { _freeVars :: FreeVars, _payload :: Type, _func :: Type } - | Outgoing { _freeVars :: FreeVars, _payload :: Type, _func :: Type } - - -data Manager - = Cmd Name - | Sub Name - | Fx Name Name - - - --- BINARY - - -instance Binary Alias where - get = liftM2 Alias get get - put (Alias a b) = put a >> put b - - -instance Binary Union where - put (Union a b c d) = put a >> put b >> put c >> put d - get = liftM4 Union get get get get - - -instance Binary Ctor where - get = liftM4 Ctor get get get get - put (Ctor a b c d) = put a >> put b >> put c >> put d - - -instance Binary CtorOpts where - put opts = - case opts of - Normal -> putWord8 0 - Enum -> putWord8 1 - Unbox -> putWord8 2 - - get = - do n <- getWord8 - case n of - 0 -> return Normal - 1 -> return Enum - 2 -> return Unbox - _ -> fail "binary encoding of CtorOpts was corrupted" - - -instance Binary Annotation where - get = liftM2 Forall get get - put (Forall a b) = put a >> put b - - -instance Binary Type where - put tipe = - case tipe of - TLambda a b -> putWord8 0 >> put a >> put b - TVar a -> putWord8 1 >> put a - TRecord a b -> putWord8 2 >> put a >> put b - TUnit -> putWord8 3 - TTuple a b c -> putWord8 4 >> put a >> put b >> put c - TAlias a b c d -> putWord8 5 >> put a >> put b >> put c >> put d - TType home name ts -> - let potentialWord = length ts + 7 in - if potentialWord <= fromIntegral (maxBound :: Word8) then - do putWord8 (fromIntegral potentialWord) - put home - put name - mapM_ put ts - else - putWord8 6 >> put home >> put name >> put ts - - get = - do word <- getWord8 - case word of - 0 -> liftM2 TLambda get get - 1 -> liftM TVar get - 2 -> liftM2 TRecord get get - 3 -> return TUnit - 4 -> liftM3 TTuple get get get - 5 -> liftM4 TAlias get get get get - 6 -> liftM3 TType get get get - n -> liftM3 TType get get (replicateM (fromIntegral (n - 7)) get) - - -instance Binary AliasType where - put aliasType = - case aliasType of - Holey tipe -> putWord8 0 >> put tipe - Filled tipe -> putWord8 1 >> put tipe - - get = - do n <- getWord8 - case n of - 0 -> liftM Holey get - 1 -> liftM Filled get - _ -> fail "binary encoding of AliasType was corrupted" - - -instance Binary FieldType where - get = liftM2 FieldType get get - put (FieldType a b) = put a >> put b diff --git a/compiler/src/AST/Optimized.hs b/compiler/src/AST/Optimized.hs deleted file mode 100644 index 9fd3a9d10e..0000000000 --- a/compiler/src/AST/Optimized.hs +++ /dev/null @@ -1,451 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -module AST.Optimized - ( Def(..) - , Expr(..) - , Global(..) - , Path(..) - , Destructor(..) - , Decider(..) - , Choice(..) - , GlobalGraph(..) - , LocalGraph(..) - , Main(..) - , Node(..) - , EffectsType(..) - , empty - , addGlobalGraph - , addLocalGraph - , addKernel - , toKernelGlobal - ) - where - - -import Control.Monad (liftM, liftM2, liftM3, liftM4) -import Data.Binary (Binary, get, put, getWord8, putWord8) -import qualified Data.Map as Map -import qualified Data.Name as Name -import Data.Name (Name) -import qualified Data.Set as Set - -import qualified AST.Canonical as Can -import qualified AST.Utils.Shader as Shader -import qualified Data.Index as Index -import qualified Elm.Float as EF -import qualified Elm.Kernel as K -import qualified Elm.ModuleName as ModuleName -import qualified Elm.Package as Pkg -import qualified Elm.String as ES -import qualified Optimize.DecisionTree as DT -import qualified Reporting.Annotation as A - - - --- EXPRESSIONS - - -data Expr - = Bool Bool - | Chr ES.String - | Str ES.String - | Int Int - | Float EF.Float - | VarLocal Name - | VarGlobal Global - | VarEnum Global Index.ZeroBased - | VarBox Global - | VarCycle ModuleName.Canonical Name - | VarDebug Name ModuleName.Canonical A.Region (Maybe Name) - | VarKernel Name Name - | List [Expr] - | Function [Name] Expr - | Call Expr [Expr] - | TailCall Name [(Name, Expr)] - | If [(Expr, Expr)] Expr - | Let Def Expr - | Destruct Destructor Expr - | Case Name Name (Decider Choice) [(Int, Expr)] - | Accessor Name - | Access Expr Name - | Update Expr (Map.Map Name Expr) - | Record (Map.Map Name Expr) - | Unit - | Tuple Expr Expr (Maybe Expr) - | Shader Shader.Source (Set.Set Name) (Set.Set Name) - - -data Global = Global ModuleName.Canonical Name - - - --- DEFINITIONS - - -data Def - = Def Name Expr - | TailDef Name [Name] Expr - - -data Destructor = - Destructor Name Path - - -data Path - = Index Index.ZeroBased Path - | Field Name Path - | Unbox Path - | Root Name - - - --- BRANCHING - - -data Decider a - = Leaf a - | Chain - { _testChain :: [(DT.Path, DT.Test)] - , _success :: Decider a - , _failure :: Decider a - } - | FanOut - { _path :: DT.Path - , _tests :: [(DT.Test, Decider a)] - , _fallback :: Decider a - } - deriving (Eq) - - -data Choice - = Inline Expr - | Jump Int - - - --- OBJECT GRAPH - - -data GlobalGraph = - GlobalGraph - { _g_nodes :: Map.Map Global Node - , _g_fields :: Map.Map Name Int - } - - -data LocalGraph = - LocalGraph - { _l_main :: Maybe Main - , _l_nodes :: Map.Map Global Node -- PERF profile switching Global to Name - , _l_fields :: Map.Map Name Int - } - - -data Main - = Static - | Dynamic - { _message :: Can.Type - , _decoder :: Expr - } - - -data Node - = Define Expr (Set.Set Global) - | DefineTailFunc [Name] Expr (Set.Set Global) - | Ctor Index.ZeroBased Int - | Enum Index.ZeroBased - | Box - | Link Global - | Cycle [Name] [(Name, Expr)] [Def] (Set.Set Global) - | Manager EffectsType - | Kernel [K.Chunk] (Set.Set Global) - | PortIncoming Expr (Set.Set Global) - | PortOutgoing Expr (Set.Set Global) - - -data EffectsType = Cmd | Sub | Fx - - - --- GRAPHS - - -{-# NOINLINE empty #-} -empty :: GlobalGraph -empty = - GlobalGraph Map.empty Map.empty - - -addGlobalGraph :: GlobalGraph -> GlobalGraph -> GlobalGraph -addGlobalGraph (GlobalGraph nodes1 fields1) (GlobalGraph nodes2 fields2) = - GlobalGraph - { _g_nodes = Map.union nodes1 nodes2 - , _g_fields = Map.union fields1 fields2 - } - - -addLocalGraph :: LocalGraph -> GlobalGraph -> GlobalGraph -addLocalGraph (LocalGraph _ nodes1 fields1) (GlobalGraph nodes2 fields2) = - GlobalGraph - { _g_nodes = Map.union nodes1 nodes2 - , _g_fields = Map.union fields1 fields2 - } - - -addKernel :: Name.Name -> [K.Chunk] -> GlobalGraph -> GlobalGraph -addKernel shortName chunks (GlobalGraph nodes fields) = - let - global = toKernelGlobal shortName - node = Kernel chunks (foldr addKernelDep Set.empty chunks) - in - GlobalGraph - { _g_nodes = Map.insert global node nodes - , _g_fields = Map.union (K.countFields chunks) fields - } - - -addKernelDep :: K.Chunk -> Set.Set Global -> Set.Set Global -addKernelDep chunk deps = - case chunk of - K.JS _ -> deps - K.ElmVar home name -> Set.insert (Global home name) deps - K.JsVar shortName _ -> Set.insert (toKernelGlobal shortName) deps - K.ElmField _ -> deps - K.JsField _ -> deps - K.JsEnum _ -> deps - K.Debug -> deps - K.Prod -> deps - - -toKernelGlobal :: Name.Name -> Global -toKernelGlobal shortName = - Global (ModuleName.Canonical Pkg.kernel shortName) Name.dollar - - - --- INSTANCES - - -instance Eq Global where - (==) (Global home1 name1) (Global home2 name2) = - name1 == name2 && home1 == home2 - - -instance Ord Global where - compare (Global home1 name1) (Global home2 name2) = - case compare name1 name2 of - LT -> LT - EQ -> compare home1 home2 - GT -> GT - - - --- BINARY - - -instance Binary Global where - get = liftM2 Global get get - put (Global a b) = put a >> put b - - -instance Binary Expr where - put expr = - case expr of - Bool a -> putWord8 0 >> put a - Chr a -> putWord8 1 >> put a - Str a -> putWord8 2 >> put a - Int a -> putWord8 3 >> put a - Float a -> putWord8 4 >> put a - VarLocal a -> putWord8 5 >> put a - VarGlobal a -> putWord8 6 >> put a - VarEnum a b -> putWord8 7 >> put a >> put b - VarBox a -> putWord8 8 >> put a - VarCycle a b -> putWord8 9 >> put a >> put b - VarDebug a b c d -> putWord8 10 >> put a >> put b >> put c >> put d - VarKernel a b -> putWord8 11 >> put a >> put b - List a -> putWord8 12 >> put a - Function a b -> putWord8 13 >> put a >> put b - Call a b -> putWord8 14 >> put a >> put b - TailCall a b -> putWord8 15 >> put a >> put b - If a b -> putWord8 16 >> put a >> put b - Let a b -> putWord8 17 >> put a >> put b - Destruct a b -> putWord8 18 >> put a >> put b - Case a b c d -> putWord8 19 >> put a >> put b >> put c >> put d - Accessor a -> putWord8 20 >> put a - Access a b -> putWord8 21 >> put a >> put b - Update a b -> putWord8 22 >> put a >> put b - Record a -> putWord8 23 >> put a - Unit -> putWord8 24 - Tuple a b c -> putWord8 25 >> put a >> put b >> put c - Shader a b c -> putWord8 26 >> put a >> put b >> put c - - get = - do word <- getWord8 - case word of - 0 -> liftM Bool get - 1 -> liftM Chr get - 2 -> liftM Str get - 3 -> liftM Int get - 4 -> liftM Float get - 5 -> liftM VarLocal get - 6 -> liftM VarGlobal get - 7 -> liftM2 VarEnum get get - 8 -> liftM VarBox get - 9 -> liftM2 VarCycle get get - 10 -> liftM4 VarDebug get get get get - 11 -> liftM2 VarKernel get get - 12 -> liftM List get - 13 -> liftM2 Function get get - 14 -> liftM2 Call get get - 15 -> liftM2 TailCall get get - 16 -> liftM2 If get get - 17 -> liftM2 Let get get - 18 -> liftM2 Destruct get get - 19 -> liftM4 Case get get get get - 20 -> liftM Accessor get - 21 -> liftM2 Access get get - 22 -> liftM2 Update get get - 23 -> liftM Record get - 24 -> pure Unit - 25 -> liftM3 Tuple get get get - 26 -> liftM3 Shader get get get - _ -> fail "problem getting Opt.Expr binary" - - -instance Binary Def where - put def = - case def of - Def a b -> putWord8 0 >> put a >> put b - TailDef a b c -> putWord8 1 >> put a >> put b >> put c - - get = - do word <- getWord8 - case word of - 0 -> liftM2 Def get get - 1 -> liftM3 TailDef get get get - _ -> fail "problem getting Opt.Def binary" - - -instance Binary Destructor where - get = liftM2 Destructor get get - put (Destructor a b) = put a >> put b - - -instance Binary Path where - put destructor = - case destructor of - Index a b -> putWord8 0 >> put a >> put b - Field a b -> putWord8 1 >> put a >> put b - Unbox a -> putWord8 2 >> put a - Root a -> putWord8 3 >> put a - - get = - do word <- getWord8 - case word of - 0 -> liftM2 Index get get - 1 -> liftM2 Field get get - 2 -> liftM Unbox get - 3 -> liftM Root get - _ -> fail "problem getting Opt.Path binary" - - -instance (Binary a) => Binary (Decider a) where - put decider = - case decider of - Leaf a -> putWord8 0 >> put a - Chain a b c -> putWord8 1 >> put a >> put b >> put c - FanOut a b c -> putWord8 2 >> put a >> put b >> put c - - get = - do word <- getWord8 - case word of - 0 -> liftM Leaf get - 1 -> liftM3 Chain get get get - 2 -> liftM3 FanOut get get get - _ -> fail "problem getting Opt.Decider binary" - - -instance Binary Choice where - put choice = - case choice of - Inline expr -> putWord8 0 >> put expr - Jump index -> putWord8 1 >> put index - - get = - do word <- getWord8 - case word of - 0 -> liftM Inline get - 1 -> liftM Jump get - _ -> fail "problem getting Opt.Choice binary" - - - -instance Binary GlobalGraph where - get = liftM2 GlobalGraph get get - put (GlobalGraph a b) = put a >> put b - - -instance Binary LocalGraph where - get = liftM3 LocalGraph get get get - put (LocalGraph a b c) = put a >> put b >> put c - - -instance Binary Main where - put main = - case main of - Static -> putWord8 0 - Dynamic a b -> putWord8 1 >> put a >> put b - - get = - do word <- getWord8 - case word of - 0 -> return Static - 1 -> liftM2 Dynamic get get - _ -> fail "problem getting Opt.Main binary" - - -instance Binary Node where - put node = - case node of - Define a b -> putWord8 0 >> put a >> put b - DefineTailFunc a b c -> putWord8 1 >> put a >> put b >> put c - Ctor a b -> putWord8 2 >> put a >> put b - Enum a -> putWord8 3 >> put a - Box -> putWord8 4 - Link a -> putWord8 5 >> put a - Cycle a b c d -> putWord8 6 >> put a >> put b >> put c >> put d - Manager a -> putWord8 7 >> put a - Kernel a b -> putWord8 8 >> put a >> put b - PortIncoming a b -> putWord8 9 >> put a >> put b - PortOutgoing a b -> putWord8 10 >> put a >> put b - - get = - do word <- getWord8 - case word of - 0 -> liftM2 Define get get - 1 -> liftM3 DefineTailFunc get get get - 2 -> liftM2 Ctor get get - 3 -> liftM Enum get - 4 -> return Box - 5 -> liftM Link get - 6 -> liftM4 Cycle get get get get - 7 -> liftM Manager get - 8 -> liftM2 Kernel get get - 9 -> liftM2 PortIncoming get get - 10 -> liftM2 PortOutgoing get get - _ -> fail "problem getting Opt.Node binary" - - -instance Binary EffectsType where - put effectsType = - case effectsType of - Cmd -> putWord8 0 - Sub -> putWord8 1 - Fx -> putWord8 2 - - get = - do word <- getWord8 - case word of - 0 -> return Cmd - 1 -> return Sub - 2 -> return Fx - _ -> fail "problem getting Opt.EffectsType binary" diff --git a/compiler/src/AST/Source.hs b/compiler/src/AST/Source.hs deleted file mode 100644 index c7ac0a12ff..0000000000 --- a/compiler/src/AST/Source.hs +++ /dev/null @@ -1,209 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -module AST.Source - ( Expr, Expr_(..), VarType(..) - , Def(..) - , Pattern, Pattern_(..) - , Type, Type_(..) - , Module(..) - , getName - , getImportName - , Import(..) - , Value(..) - , Union(..) - , Alias(..) - , Infix(..) - , Port(..) - , Effects(..) - , Manager(..) - , Docs(..) - , Comment(..) - , Exposing(..) - , Exposed(..) - , Privacy(..) - ) - where - - -import Data.Name (Name) -import qualified Data.Name as Name - -import qualified AST.Utils.Binop as Binop -import qualified AST.Utils.Shader as Shader -import qualified Elm.Float as EF -import qualified Elm.String as ES -import qualified Parse.Primitives as P -import qualified Reporting.Annotation as A - - - --- EXPRESSIONS - - -type Expr = A.Located Expr_ - - -data Expr_ - = Chr ES.String - | Str ES.String - | Int Int - | Float EF.Float - | Var VarType Name - | VarQual VarType Name Name - | List [Expr] - | Op Name - | Negate Expr - | Binops [(Expr, A.Located Name)] Expr - | Lambda [Pattern] Expr - | Call Expr [Expr] - | If [(Expr, Expr)] Expr - | Let [A.Located Def] Expr - | Case Expr [(Pattern, Expr)] - | Accessor Name - | Access Expr (A.Located Name) - | Update (A.Located Name) [(A.Located Name, Expr)] - | Record [(A.Located Name, Expr)] - | Unit - | Tuple Expr Expr [Expr] - | Shader Shader.Source Shader.Types - - -data VarType = LowVar | CapVar - - - --- DEFINITIONS - - -data Def - = Define (A.Located Name) [Pattern] Expr (Maybe Type) - | Destruct Pattern Expr - - - --- PATTERN - - -type Pattern = A.Located Pattern_ - - -data Pattern_ - = PAnything - | PVar Name - | PRecord [A.Located Name] - | PAlias Pattern (A.Located Name) - | PUnit - | PTuple Pattern Pattern [Pattern] - | PCtor A.Region Name [Pattern] - | PCtorQual A.Region Name Name [Pattern] - | PList [Pattern] - | PCons Pattern Pattern - | PChr ES.String - | PStr ES.String - | PInt Int - - - --- TYPE - - -type Type = - A.Located Type_ - - -data Type_ - = TLambda Type Type - | TVar Name - | TType A.Region Name [Type] - | TTypeQual A.Region Name Name [Type] - | TRecord [(A.Located Name, Type)] (Maybe (A.Located Name)) - | TUnit - | TTuple Type Type [Type] - - - --- MODULE - - -data Module = - Module - { _name :: Maybe (A.Located Name) - , _exports :: A.Located Exposing - , _docs :: Docs - , _imports :: [Import] - , _values :: [A.Located Value] - , _unions :: [A.Located Union] - , _aliases :: [A.Located Alias] - , _binops :: [A.Located Infix] - , _effects :: Effects - } - - -getName :: Module -> Name -getName (Module maybeName _ _ _ _ _ _ _ _) = - case maybeName of - Just (A.At _ name) -> - name - - Nothing -> - Name._Main - - -getImportName :: Import -> Name -getImportName (Import (A.At _ name) _ _) = - name - - -data Import = - Import - { _import :: A.Located Name - , _alias :: Maybe Name - , _exposing :: Exposing - } - - -data Value = Value (A.Located Name) [Pattern] Expr (Maybe Type) -data Union = Union (A.Located Name) [A.Located Name] [(A.Located Name, [Type])] -data Alias = Alias (A.Located Name) [A.Located Name] Type -data Infix = Infix Name Binop.Associativity Binop.Precedence Name -data Port = Port (A.Located Name) Type - - -data Effects - = NoEffects - | Ports [Port] - | Manager A.Region Manager - - -data Manager - = Cmd (A.Located Name) - | Sub (A.Located Name) - | Fx (A.Located Name) (A.Located Name) - - -data Docs - = NoDocs A.Region - | YesDocs Comment [(Name, Comment)] - - -newtype Comment = - Comment P.Snippet - - - --- EXPOSING - - -data Exposing - = Open - | Explicit [Exposed] - - -data Exposed - = Lower (A.Located Name) - | Upper (A.Located Name) Privacy - | Operator A.Region Name - - -data Privacy - = Public A.Region - | Private diff --git a/compiler/src/AST/Utils/Binop.hs b/compiler/src/AST/Utils/Binop.hs deleted file mode 100644 index ce05756125..0000000000 --- a/compiler/src/AST/Utils/Binop.hs +++ /dev/null @@ -1,55 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -module AST.Utils.Binop - ( Precedence(..) - , Associativity(..) - ) - where - - -import Prelude hiding (Either(..)) -import Control.Monad (liftM) -import Data.Binary - - - --- BINOP STUFF - - -newtype Precedence = Precedence Int - deriving (Eq, Ord) - - -data Associativity - = Left - | Non - | Right - deriving (Eq) - - - --- BINARY - - -instance Binary Precedence where - get = - liftM Precedence get - - put (Precedence n) = - put n - - -instance Binary Associativity where - get = - do n <- getWord8 - case n of - 0 -> return Left - 1 -> return Non - 2 -> return Right - _ -> fail "Error reading valid associativity from serialized string" - - put assoc = - putWord8 $ - case assoc of - Left -> 0 - Non -> 1 - Right -> 2 diff --git a/compiler/src/AST/Utils/Shader.hs b/compiler/src/AST/Utils/Shader.hs deleted file mode 100644 index e219c12af8..0000000000 --- a/compiler/src/AST/Utils/Shader.hs +++ /dev/null @@ -1,91 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE EmptyDataDecls #-} -module AST.Utils.Shader - ( Source - , Types(..) - , Type(..) - , fromChars - , toJsStringBuilder - ) - where - - -import Control.Monad (liftM) -import Data.Binary (Binary, get, put) -import qualified Data.ByteString as BS -import qualified Data.ByteString.Builder as B -import qualified Data.ByteString.UTF8 as BS_UTF8 -import qualified Data.Map as Map -import qualified Data.Name as Name - - - --- SOURCE - - -newtype Source = - Source BS.ByteString - - - --- TYPES - - -data Types = - Types - { _attribute :: Map.Map Name.Name Type - , _uniform :: Map.Map Name.Name Type - , _varying :: Map.Map Name.Name Type - } - - -data Type - = Int - | Float - | V2 - | V3 - | V4 - | M4 - | Texture - - - --- TO BUILDER - - -toJsStringBuilder :: Source -> B.Builder -toJsStringBuilder (Source src) = - B.byteString src - - - --- FROM CHARS - - -fromChars :: [Char] -> Source -fromChars chars = - Source (BS_UTF8.fromString (escape chars)) - - -escape :: [Char] -> [Char] -escape chars = - case chars of - [] -> - [] - - c:cs - | c == '\r' -> escape cs - | c == '\n' -> '\\' : 'n' : escape cs - | c == '\"' -> '\\' : '"' : escape cs - | c == '\'' -> '\\' : '\'' : escape cs - | c == '\\' -> '\\' : '\\' : escape cs - | otherwise -> c : escape cs - - - --- BINARY - - -instance Binary Source where - get = liftM Source get - put (Source a) = put a diff --git a/compiler/src/AST/Utils/Type.hs b/compiler/src/AST/Utils/Type.hs deleted file mode 100644 index bf77189348..0000000000 --- a/compiler/src/AST/Utils/Type.hs +++ /dev/null @@ -1,126 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE OverloadedStrings #-} -module AST.Utils.Type - ( delambda - , dealias - , deepDealias - , iteratedDealias - ) - where - - -import qualified Data.Map as Map -import qualified Data.Name as Name - -import AST.Canonical (Type(..), AliasType(..), FieldType(..)) - - - --- DELAMBDA - - -delambda :: Type -> [Type] -delambda tipe = - case tipe of - TLambda arg result -> - arg : delambda result - - _ -> - [tipe] - - - --- DEALIAS - - -dealias :: [(Name.Name, Type)] -> AliasType -> Type -dealias args aliasType = - case aliasType of - Holey tipe -> - dealiasHelp (Map.fromList args) tipe - - Filled tipe -> - tipe - - -dealiasHelp :: Map.Map Name.Name Type -> Type -> Type -dealiasHelp typeTable tipe = - case tipe of - TLambda a b -> - TLambda - (dealiasHelp typeTable a) - (dealiasHelp typeTable b) - - TVar x -> - Map.findWithDefault tipe x typeTable - - TRecord fields ext -> - TRecord (Map.map (dealiasField typeTable) fields) ext - - TAlias home name args t' -> - TAlias home name (map (fmap (dealiasHelp typeTable)) args) t' - - TType home name args -> - TType home name (map (dealiasHelp typeTable) args) - - TUnit -> - TUnit - - TTuple a b maybeC -> - TTuple - (dealiasHelp typeTable a) - (dealiasHelp typeTable b) - (fmap (dealiasHelp typeTable) maybeC) - - -dealiasField :: Map.Map Name.Name Type -> FieldType -> FieldType -dealiasField typeTable (FieldType index tipe) = - FieldType index (dealiasHelp typeTable tipe) - - - --- DEEP DEALIAS - - -deepDealias :: Type -> Type -deepDealias tipe = - case tipe of - TLambda a b -> - TLambda (deepDealias a) (deepDealias b) - - TVar _ -> - tipe - - TRecord fields ext -> - TRecord (Map.map deepDealiasField fields) ext - - TAlias _ _ args tipe' -> - deepDealias (dealias args tipe') - - TType home name args -> - TType home name (map deepDealias args) - - TUnit -> - TUnit - - TTuple a b c -> - TTuple (deepDealias a) (deepDealias b) (fmap deepDealias c) - - -deepDealiasField :: FieldType -> FieldType -deepDealiasField (FieldType index tipe) = - FieldType index (deepDealias tipe) - - - --- ITERATED DEALIAS - - -iteratedDealias :: Type -> Type -iteratedDealias tipe = - case tipe of - TAlias _ _ args realType -> - iteratedDealias (dealias args realType) - - _ -> - tipe diff --git a/compiler/src/Canonicalize/Effects.hs b/compiler/src/Canonicalize/Effects.hs deleted file mode 100644 index c977d24031..0000000000 --- a/compiler/src/Canonicalize/Effects.hs +++ /dev/null @@ -1,251 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE OverloadedStrings #-} -module Canonicalize.Effects - ( canonicalize - , checkPayload - ) - where - -import qualified Data.Foldable as F -import qualified Data.Map as Map -import qualified Data.Name as Name - -import qualified AST.Canonical as Can -import qualified AST.Source as Src -import qualified AST.Utils.Type as Type -import qualified Canonicalize.Environment as Env -import qualified Canonicalize.Type as Type -import qualified Elm.ModuleName as ModuleName -import qualified Reporting.Annotation as A -import qualified Reporting.Error.Canonicalize as Error -import qualified Reporting.Result as Result - - - --- RESULT - - -type Result i w a = - Result.Result i w Error.Error a - - - --- CANONICALIZE - - -canonicalize - :: Env.Env - -> [A.Located Src.Value] - -> Map.Map Name.Name union - -> Src.Effects - -> Result i w Can.Effects -canonicalize env values unions effects = - case effects of - Src.NoEffects -> - Result.ok Can.NoEffects - - Src.Ports ports -> - do pairs <- traverse (canonicalizePort env) ports - return $ Can.Ports (Map.fromList pairs) - - Src.Manager region manager -> - let dict = Map.fromList (map toNameRegion values) in - Can.Manager - <$> verifyManager region dict "init" - <*> verifyManager region dict "onEffects" - <*> verifyManager region dict "onSelfMsg" - <*> - case manager of - Src.Cmd cmdType -> - Can.Cmd - <$> verifyEffectType cmdType unions - <* verifyManager region dict "cmdMap" - - Src.Sub subType -> - Can.Sub - <$> verifyEffectType subType unions - <* verifyManager region dict "subMap" - - Src.Fx cmdType subType -> - Can.Fx - <$> verifyEffectType cmdType unions - <*> verifyEffectType subType unions - <* verifyManager region dict "cmdMap" - <* verifyManager region dict "subMap" - - - --- CANONICALIZE PORT - - -canonicalizePort :: Env.Env -> Src.Port -> Result i w (Name.Name, Can.Port) -canonicalizePort env (Src.Port (A.At region portName) tipe) = - do (Can.Forall freeVars ctipe) <- Type.toAnnotation env tipe - case reverse (Type.delambda (Type.deepDealias ctipe)) of - Can.TType home name [msg] : revArgs - | home == ModuleName.cmd && name == Name.cmd -> - case revArgs of - [] -> - Result.throw (Error.PortTypeInvalid region portName Error.CmdNoArg) - - [outgoingType] -> - case msg of - Can.TVar _ -> - case checkPayload outgoingType of - Right () -> - Result.ok (portName, Can.Outgoing freeVars outgoingType ctipe) - - Left (badType, err) -> - Result.throw (Error.PortPayloadInvalid region portName badType err) - - _ -> - Result.throw (Error.PortTypeInvalid region portName Error.CmdBadMsg) - - _ -> - Result.throw (Error.PortTypeInvalid region portName (Error.CmdExtraArgs (length revArgs))) - - | home == ModuleName.sub && name == Name.sub -> - case revArgs of - [Can.TLambda incomingType (Can.TVar msg1)] -> - case msg of - Can.TVar msg2 | msg1 == msg2 -> - case checkPayload incomingType of - Right () -> - Result.ok (portName, Can.Incoming freeVars incomingType ctipe) - - Left (badType, err) -> - Result.throw (Error.PortPayloadInvalid region portName badType err) - - _ -> - Result.throw (Error.PortTypeInvalid region portName Error.SubBad) - - _ -> - Result.throw (Error.PortTypeInvalid region portName Error.SubBad) - - _ -> - Result.throw (Error.PortTypeInvalid region portName Error.NotCmdOrSub) - - - --- VERIFY MANAGER - - -verifyEffectType :: A.Located Name.Name -> Map.Map Name.Name a -> Result i w Name.Name -verifyEffectType (A.At region name) unions = - if Map.member name unions then - Result.ok name - else - Result.throw (Error.EffectNotFound region name) - - -toNameRegion :: A.Located Src.Value -> (Name.Name, A.Region) -toNameRegion (A.At _ (Src.Value (A.At region name) _ _ _)) = - (name, region) - - -verifyManager :: A.Region -> Map.Map Name.Name A.Region -> Name.Name -> Result i w A.Region -verifyManager tagRegion values name = - case Map.lookup name values of - Just region -> - Result.ok region - - Nothing -> - Result.throw (Error.EffectFunctionNotFound tagRegion name) - - - --- CHECK PAYLOAD TYPES - - -checkPayload :: Can.Type -> Either (Can.Type, Error.InvalidPayload) () -checkPayload tipe = - case tipe of - Can.TAlias _ _ args aliasedType -> - checkPayload (Type.dealias args aliasedType) - - Can.TType home name args -> - case args of - [] - | isJson home name -> Right () - | isString home name -> Right () - | isIntFloatBool home name -> Right () - - [arg] - | isList home name -> checkPayload arg - | isMaybe home name -> checkPayload arg - | isArray home name -> checkPayload arg - - _ -> - Left (tipe, Error.UnsupportedType name) - - Can.TUnit -> - Right () - - Can.TTuple a b maybeC -> - do checkPayload a - checkPayload b - case maybeC of - Nothing -> - Right () - - Just c -> - checkPayload c - - Can.TVar name -> - Left (tipe, Error.TypeVariable name) - - Can.TLambda _ _ -> - Left (tipe, Error.Function) - - Can.TRecord _ (Just _) -> - Left (tipe, Error.ExtendedRecord) - - Can.TRecord fields Nothing -> - F.traverse_ checkFieldPayload fields - - -checkFieldPayload :: Can.FieldType -> Either (Can.Type, Error.InvalidPayload) () -checkFieldPayload (Can.FieldType _ tipe) = - checkPayload tipe - - -isIntFloatBool :: ModuleName.Canonical -> Name.Name -> Bool -isIntFloatBool home name = - home == ModuleName.basics - && - (name == Name.int || name == Name.float || name == Name.bool) - - -isString :: ModuleName.Canonical -> Name.Name -> Bool -isString home name = - home == ModuleName.string - && - name == Name.string - - -isJson :: ModuleName.Canonical -> Name.Name -> Bool -isJson home name = - home == ModuleName.jsonEncode - && - name == Name.value - - -isList :: ModuleName.Canonical -> Name.Name -> Bool -isList home name = - home == ModuleName.list - && - name == Name.list - - -isMaybe :: ModuleName.Canonical -> Name.Name -> Bool -isMaybe home name = - home == ModuleName.maybe - && - name == Name.maybe - - -isArray :: ModuleName.Canonical -> Name.Name -> Bool -isArray home name = - home == ModuleName.array - && - name == Name.array diff --git a/compiler/src/Canonicalize/Environment.hs b/compiler/src/Canonicalize/Environment.hs deleted file mode 100644 index daef1ca541..0000000000 --- a/compiler/src/Canonicalize/Environment.hs +++ /dev/null @@ -1,245 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE OverloadedStrings #-} -module Canonicalize.Environment - ( Env(..) - , Exposed - , Qualified - , Var(..) - , Type(..) - , Ctor(..) - , addLocals - , findType - , findTypeQual - , findCtor - , findCtorQual - , findBinop - , Binop(..) - ) - where - - -import qualified Data.Map.Merge.Strict as Map -import qualified Data.Map.Strict as Map -import qualified Data.Map.Strict.Internal as I -import qualified Data.Name as Name - -import qualified AST.Utils.Binop as Binop -import qualified AST.Canonical as Can -import qualified Data.Index as Index -import qualified Elm.ModuleName as ModuleName -import qualified Reporting.Annotation as A -import qualified Reporting.Error.Canonicalize as Error -import qualified Reporting.Result as Result - - - --- RESULT - - -type Result i w a = - Result.Result i w Error.Error a - - - --- ENVIRONMENT - - -data Env = - Env - { _home :: ModuleName.Canonical - , _vars :: Map.Map Name.Name Var - , _types :: Exposed Type - , _ctors :: Exposed Ctor - , _binops :: Exposed Binop - , _q_vars :: Qualified Can.Annotation - , _q_types :: Qualified Type - , _q_ctors :: Qualified Ctor - } - - -type Exposed a = - Map.Map Name.Name (Map.Map ModuleName.Canonical a) - - -type Qualified a = - Map.Map Name.Name (Map.Map Name.Name (Map.Map ModuleName.Canonical a)) - - - --- VARIABLES - - -data Var - = Local A.Region - | TopLevel A.Region - | Foreign (Map.Map ModuleName.Canonical Can.Annotation) - - - --- TYPES - - -data Type - = Alias Int ModuleName.Canonical [Name.Name] Can.Type - | Union Int ModuleName.Canonical - - - --- CTORS - - -data Ctor - = RecordCtor ModuleName.Canonical [Name.Name] Can.Type - | Ctor - { _c_home :: ModuleName.Canonical - , _c_type :: Name.Name - , _c_union :: Can.Union - , _c_index :: Index.ZeroBased - , _c_args :: [Can.Type] - } - - - --- BINOPS - - -data Binop = - Binop - { _op :: Name.Name - , _op_home :: ModuleName.Canonical - , _op_name :: Name.Name - , _op_annotation :: Can.Annotation - , _op_associativity :: Binop.Associativity - , _op_precedence :: Binop.Precedence - } - - - --- VARIABLE -- ADD LOCALS - - -addLocals :: Map.Map Name.Name A.Region -> Env -> Result i w Env -addLocals names (Env home vars ts cs bs qvs qts qcs) = - do newVars <- - Map.mergeA - (Map.mapMissing addLocalLeft) - (Map.mapMissing (\_ homes -> homes)) - (Map.zipWithAMatched addLocalBoth) - names - vars - - Result.ok (Env home newVars ts cs bs qvs qts qcs) - - -addLocalLeft :: Name.Name -> A.Region -> Var -addLocalLeft _ region = - Local region - - -addLocalBoth :: Name.Name -> A.Region -> Var -> Result i w Var -addLocalBoth name region var = - case var of - Foreign _ -> - Result.ok (Local region) - - Local parentRegion -> - Result.throw (Error.Shadowing name parentRegion region) - - TopLevel parentRegion -> - Result.throw (Error.Shadowing name parentRegion region) - - - --- FIND TYPE - - -findType :: A.Region -> Env -> Name.Name -> Result i w Type -findType region (Env _ _ ts _ _ _ qts _) name = - case Map.lookup name ts of - Just (I.Bin 1 _ tipe _ _) -> - Result.ok tipe - - Just homes -> - Result.throw (Error.AmbiguousType region Nothing name (Map.keys homes)) - - Nothing -> - Result.throw (Error.NotFoundType region Nothing name (toPossibleNames ts qts)) - - -findTypeQual :: A.Region -> Env -> Name.Name -> Name.Name -> Result i w Type -findTypeQual region (Env _ _ ts _ _ _ qts _) prefix name = - case Map.lookup prefix qts of - Just qualified -> - case Map.lookup name qualified of - Just (I.Bin 1 _ tipe _ _) -> - Result.ok tipe - - Just homes -> - Result.throw (Error.AmbiguousType region (Just prefix) name (Map.keys homes)) - - Nothing -> - Result.throw (Error.NotFoundType region (Just prefix) name (toPossibleNames ts qts)) - - Nothing -> - Result.throw (Error.NotFoundType region (Just prefix) name (toPossibleNames ts qts)) - - - --- FIND CTOR - - -findCtor :: A.Region -> Env -> Name.Name -> Result i w Ctor -findCtor region (Env _ _ _ cs _ _ _ qcs) name = - case Map.lookup name cs of - Just (I.Bin 1 _ ctor _ _) -> - Result.ok ctor - - Just homes -> - Result.throw (Error.AmbiguousVariant region Nothing name (Map.keys homes)) - - Nothing -> - Result.throw (Error.NotFoundVariant region Nothing name (toPossibleNames cs qcs)) - - -findCtorQual :: A.Region -> Env -> Name.Name -> Name.Name -> Result i w Ctor -findCtorQual region (Env _ _ _ cs _ _ _ qcs) prefix name = - case Map.lookup prefix qcs of - Just qualified -> - case Map.lookup name qualified of - Just (I.Bin 1 _ pattern _ _) -> - Result.ok pattern - - Just homes -> - Result.throw (Error.AmbiguousVariant region (Just prefix) name (Map.keys homes)) - - Nothing -> - Result.throw (Error.NotFoundVariant region (Just prefix) name (toPossibleNames cs qcs)) - - Nothing -> - Result.throw (Error.NotFoundVariant region (Just prefix) name (toPossibleNames cs qcs)) - - - --- FIND BINOP - - -findBinop :: A.Region -> Env -> Name.Name -> Result i w Binop -findBinop region (Env _ _ _ _ binops _ _ _) name = - case Map.lookup name binops of - Just (I.Bin 1 _ binop _ _) -> - Result.ok binop - - Just homes -> - Result.throw (Error.AmbiguousBinop region name (Map.keys homes)) - - Nothing -> - Result.throw (Error.NotFoundBinop region name (Map.keysSet binops)) - - - --- TO POSSIBLE NAMES - - -toPossibleNames :: Exposed a -> Qualified a -> Error.PossibleNames -toPossibleNames exposed qualified = - Error.PossibleNames (Map.keysSet exposed) (Map.map Map.keysSet qualified) diff --git a/compiler/src/Canonicalize/Environment/Dups.hs b/compiler/src/Canonicalize/Environment/Dups.hs deleted file mode 100644 index 290a2277db..0000000000 --- a/compiler/src/Canonicalize/Environment/Dups.hs +++ /dev/null @@ -1,118 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE OverloadedStrings #-} -module Canonicalize.Environment.Dups - ( detect - , checkFields - , checkFields' - , Dict - , none - , one - , insert - , union - , unions - ) - where - - -import qualified Data.Map as Map -import qualified Data.Name as Name - -import qualified Data.OneOrMore as OneOrMore -import qualified Reporting.Annotation as A -import qualified Reporting.Error.Canonicalize as Error -import qualified Reporting.Result as Result - - - --- DUPLICATE TRACKER - - -type Dict value = - Map.Map Name.Name (OneOrMore.OneOrMore (Info value)) - - -data Info value = - Info - { _region :: A.Region - , _value :: value - } - - - --- DETECT - - -type ToError = - Name.Name -> A.Region -> A.Region -> Error.Error - - -detect :: ToError -> Dict a -> Result.Result i w Error.Error (Map.Map Name.Name a) -detect toError dict = - Map.traverseWithKey (detectHelp toError) dict - - -detectHelp :: ToError -> Name.Name -> OneOrMore.OneOrMore (Info a) -> Result.Result i w Error.Error a -detectHelp toError name values = - case values of - OneOrMore.One (Info _ value) -> - return value - - OneOrMore.More left right -> - let - (Info r1 _, Info r2 _) = - OneOrMore.getFirstTwo left right - in - Result.throw (toError name r1 r2) - - - --- CHECK FIELDS - - -checkFields :: [(A.Located Name.Name, a)] -> Result.Result i w Error.Error (Map.Map Name.Name a) -checkFields fields = - detect Error.DuplicateField (foldr addField none fields) - - -addField :: (A.Located Name.Name, a) -> Dict a -> Dict a -addField (A.At region name, value) dups = - Map.insertWith OneOrMore.more name (OneOrMore.one (Info region value)) dups - - -checkFields' :: (A.Region -> a -> b) -> [(A.Located Name.Name, a)] -> Result.Result i w Error.Error (Map.Map Name.Name b) -checkFields' toValue fields = - detect Error.DuplicateField (foldr (addField' toValue) none fields) - - -addField' :: (A.Region -> a -> b) -> (A.Located Name.Name, a) -> Dict b -> Dict b -addField' toValue (A.At region name, value) dups = - Map.insertWith OneOrMore.more name (OneOrMore.one (Info region (toValue region value))) dups - - - --- BUILDING DICTIONARIES - - -none :: Dict a -none = - Map.empty - - -one :: Name.Name -> A.Region -> value -> Dict value -one name region value = - Map.singleton name (OneOrMore.one (Info region value)) - - -insert :: Name.Name -> A.Region -> a -> Dict a -> Dict a -insert name region value dict = - Map.insertWith OneOrMore.more name (OneOrMore.one (Info region value)) dict - - -union :: Dict a -> Dict a -> Dict a -union a b = - Map.unionWith OneOrMore.more a b - - -unions :: [Dict a] -> Dict a -unions dicts = - Map.unionsWith OneOrMore.more dicts diff --git a/compiler/src/Canonicalize/Environment/Foreign.hs b/compiler/src/Canonicalize/Environment/Foreign.hs deleted file mode 100644 index 0ed6513fb5..0000000000 --- a/compiler/src/Canonicalize/Environment/Foreign.hs +++ /dev/null @@ -1,292 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE OverloadedStrings #-} -module Canonicalize.Environment.Foreign - ( createInitialEnv - ) - where - - -import Control.Monad (foldM) -import qualified Data.List as List -import qualified Data.Map.Strict as Map -import Data.Map.Strict ((!)) -import qualified Data.Name as Name - -import qualified AST.Canonical as Can -import qualified AST.Source as Src -import qualified Canonicalize.Environment as Env -import qualified Elm.Interface as I -import qualified Elm.ModuleName as ModuleName -import qualified Elm.Package as Pkg -import qualified Reporting.Annotation as A -import qualified Reporting.Error.Canonicalize as Error -import qualified Reporting.Result as Result - - - --- RESULT - - -type Result i w a = - Result.Result i w Error.Error a - - -createInitialEnv :: ModuleName.Canonical -> Map.Map ModuleName.Raw I.Interface -> [Src.Import] -> Result i w Env.Env -createInitialEnv home ifaces imports = - do (State vs ts cs bs qvs qts qcs) <- foldM (addImport ifaces) emptyState (toSafeImports home imports) - Result.ok (Env.Env home (Map.map Env.Foreign vs) ts cs bs qvs qts qcs) - - - --- STATE - - -data State = - State - { _vars :: Env.Exposed Can.Annotation - , _types :: Env.Exposed Env.Type - , _ctors :: Env.Exposed Env.Ctor - , _binops :: Env.Exposed Env.Binop - , _q_vars :: Env.Qualified Can.Annotation - , _q_types :: Env.Qualified Env.Type - , _q_ctors :: Env.Qualified Env.Ctor - } - - -emptyState :: State -emptyState = - State Map.empty emptyTypes Map.empty Map.empty Map.empty Map.empty Map.empty - - -emptyTypes :: Env.Exposed Env.Type -emptyTypes = - Map.singleton "List" (Map.singleton ModuleName.list (Env.Union 1 ModuleName.list)) - - - --- TO SAFE IMPORTS - - -toSafeImports :: ModuleName.Canonical -> [Src.Import] -> [Src.Import] -toSafeImports (ModuleName.Canonical pkg _) imports = - if Pkg.isKernel pkg - then filter isNormal imports - else imports - - -isNormal :: Src.Import -> Bool -isNormal (Src.Import (A.At _ name) maybeAlias _) = - if Name.isKernel name - then - case maybeAlias of - Nothing -> False - Just _ -> error "kernel imports cannot use `as`" - else - True - - - --- ADD IMPORTS - - -addImport :: Map.Map ModuleName.Raw I.Interface -> State -> Src.Import -> Result i w State -addImport ifaces (State vs ts cs bs qvs qts qcs) (Src.Import (A.At _ name) maybeAlias exposing) = - let - (I.Interface pkg defs unions aliases binops) = ifaces ! name - !prefix = maybe name id maybeAlias - !home = ModuleName.Canonical pkg name - - !rawTypeInfo = - Map.union - (Map.mapMaybeWithKey (unionToType home) unions) - (Map.mapMaybeWithKey (aliasToType home) aliases) - - !vars = Map.map (Map.singleton home) defs - !types = Map.map (Map.singleton home . fst) rawTypeInfo - !ctors = Map.foldr (addExposed . snd) Map.empty rawTypeInfo - - !qvs2 = addQualified prefix vars qvs - !qts2 = addQualified prefix types qts - !qcs2 = addQualified prefix ctors qcs - in - case exposing of - Src.Open -> - let - !vs2 = addExposed vs vars - !ts2 = addExposed ts types - !cs2 = addExposed cs ctors - !bs2 = addExposed bs (Map.mapWithKey (binopToBinop home) binops) - in - Result.ok (State vs2 ts2 cs2 bs2 qvs2 qts2 qcs2) - - Src.Explicit exposedList -> - foldM - (addExposedValue home vars rawTypeInfo binops) - (State vs ts cs bs qvs2 qts2 qcs2) - exposedList - - -addExposed :: Env.Exposed a -> Env.Exposed a -> Env.Exposed a -addExposed = - Map.unionWith Map.union - - -addQualified :: Name.Name -> Env.Exposed a -> Env.Qualified a -> Env.Qualified a -addQualified prefix exposed qualified = - Map.insertWith addExposed prefix exposed qualified - - - --- UNION - - -unionToType :: ModuleName.Canonical -> Name.Name -> I.Union -> Maybe (Env.Type, Env.Exposed Env.Ctor) -unionToType home name union = - unionToTypeHelp home name <$> I.toPublicUnion union - - -unionToTypeHelp :: ModuleName.Canonical -> Name.Name -> Can.Union -> (Env.Type, Env.Exposed Env.Ctor) -unionToTypeHelp home name union@(Can.Union vars ctors _ _) = - let - addCtor dict (Can.Ctor ctor index _ args) = - Map.insert ctor (Map.singleton home (Env.Ctor home name union index args)) dict - in - ( Env.Union (length vars) home - , List.foldl' addCtor Map.empty ctors - ) - - - --- ALIAS - - -aliasToType :: ModuleName.Canonical -> Name.Name -> I.Alias -> Maybe (Env.Type, Env.Exposed Env.Ctor) -aliasToType home name alias = - aliasToTypeHelp home name <$> I.toPublicAlias alias - - -aliasToTypeHelp :: ModuleName.Canonical -> Name.Name -> Can.Alias -> (Env.Type, Env.Exposed Env.Ctor) -aliasToTypeHelp home name (Can.Alias vars tipe) = - ( - Env.Alias (length vars) home vars tipe - , - case tipe of - Can.TRecord fields Nothing -> - let - avars = map (\var -> (var, Can.TVar var)) vars - alias = - foldr - (\(_,t1) t2 -> Can.TLambda t1 t2) - (Can.TAlias home name avars (Can.Filled tipe)) - (Can.fieldsToList fields) - in - Map.singleton name (Map.singleton home (Env.RecordCtor home vars alias)) - - _ -> - Map.empty - ) - - - --- BINOP - - -binopToBinop :: ModuleName.Canonical -> Name.Name -> I.Binop -> Map.Map ModuleName.Canonical Env.Binop -binopToBinop home op (I.Binop name annotation associativity precedence) = - Map.singleton home (Env.Binop op home name annotation associativity precedence) - - - --- ADD EXPOSED VALUE - - -addExposedValue - :: ModuleName.Canonical - -> Env.Exposed Can.Annotation - -> Map.Map Name.Name (Env.Type, Env.Exposed Env.Ctor) - -> Map.Map Name.Name I.Binop - -> State - -> Src.Exposed - -> Result i w State -addExposedValue home vars types binops (State vs ts cs bs qvs qts qcs) exposed = - case exposed of - Src.Lower (A.At region name) -> - case Map.lookup name vars of - Just info -> - Result.ok (State (Map.insertWith Map.union name info vs) ts cs bs qvs qts qcs) - - Nothing -> - Result.throw (Error.ImportExposingNotFound region home name (Map.keys vars)) - - Src.Upper (A.At region name) privacy -> - case privacy of - Src.Private -> - case Map.lookup name types of - Just (tipe, ctors) -> - case tipe of - Env.Union _ _ -> - let - !ts2 = Map.insert name (Map.singleton home tipe) ts - in - Result.ok (State vs ts2 cs bs qvs qts qcs) - - Env.Alias _ _ _ _ -> - let - !ts2 = Map.insert name (Map.singleton home tipe) ts - !cs2 = addExposed cs ctors - in - Result.ok (State vs ts2 cs2 bs qvs qts qcs) - - Nothing -> - case Map.lookup name (toCtors types) of - Just tipe -> - Result.throw $ Error.ImportCtorByName region name tipe - - Nothing -> - Result.throw $ Error.ImportExposingNotFound region home name (Map.keys types) - - Src.Public dotDotRegion -> - case Map.lookup name types of - Just (tipe, ctors) -> - case tipe of - Env.Union _ _ -> - let - !ts2 = Map.insert name (Map.singleton home tipe) ts - !cs2 = addExposed cs ctors - in - Result.ok (State vs ts2 cs2 bs qvs qts qcs) - - Env.Alias _ _ _ _ -> - Result.throw (Error.ImportOpenAlias dotDotRegion name) - - Nothing -> - Result.throw (Error.ImportExposingNotFound region home name (Map.keys types)) - - Src.Operator region op -> - case Map.lookup op binops of - Just binop -> - let - !bs2 = Map.insert op (binopToBinop home op binop) bs - in - Result.ok (State vs ts cs bs2 qvs qts qcs) - - Nothing -> - Result.throw (Error.ImportExposingNotFound region home op (Map.keys binops)) - - - -toCtors :: Map.Map Name.Name (Env.Type, Env.Exposed Env.Ctor) -> Map.Map Name.Name Name.Name -toCtors types = - Map.foldr addCtors Map.empty types - where - addCtors (_, exposedCtors) dict = - Map.foldrWithKey addCtor dict exposedCtors - - addCtor ctorName homes dict = - case Map.elems homes of - [Env.Ctor _ tipeName _ _ _] -> - Map.insert ctorName tipeName dict - - _ -> - dict diff --git a/compiler/src/Canonicalize/Environment/Local.hs b/compiler/src/Canonicalize/Environment/Local.hs deleted file mode 100644 index 0f9d308336..0000000000 --- a/compiler/src/Canonicalize/Environment/Local.hs +++ /dev/null @@ -1,355 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE OverloadedStrings #-} -module Canonicalize.Environment.Local - ( add - ) - where - - -import Control.Monad (foldM) -import qualified Data.Graph as Graph -import qualified Data.List as List -import qualified Data.Map.Strict as Map -import qualified Data.Name as Name - -import qualified AST.Canonical as Can -import qualified AST.Source as Src -import qualified Canonicalize.Environment as Env -import qualified Canonicalize.Environment.Dups as Dups -import qualified Canonicalize.Type as Type -import qualified Data.Index as Index -import qualified Elm.ModuleName as ModuleName -import qualified Reporting.Annotation as A -import qualified Reporting.Error.Canonicalize as Error -import qualified Reporting.Result as Result - - - --- RESULT - - -type Result i w a = - Result.Result i w Error.Error a - - -type Unions = Map.Map Name.Name Can.Union -type Aliases = Map.Map Name.Name Can.Alias - - -add :: Src.Module -> Env.Env -> Result i w (Env.Env, Unions, Aliases) -add module_ env = - addCtors module_ =<< addVars module_ =<< addTypes module_ env - - - --- ADD VARS - - -addVars :: Src.Module -> Env.Env -> Result i w Env.Env -addVars module_ (Env.Env home vs ts cs bs qvs qts qcs) = - do topLevelVars <- collectVars module_ - let vs2 = Map.union topLevelVars vs - -- Use union to overwrite foreign stuff. - Result.ok $ Env.Env home vs2 ts cs bs qvs qts qcs - - -collectVars :: Src.Module -> Result i w (Map.Map Name.Name Env.Var) -collectVars (Src.Module _ _ _ _ values _ _ _ effects) = - let - addDecl dict (A.At _ (Src.Value (A.At region name) _ _ _)) = - Dups.insert name region (Env.TopLevel region) dict - in - Dups.detect Error.DuplicateDecl $ - List.foldl' addDecl (toEffectDups effects) values - - -toEffectDups :: Src.Effects -> Dups.Dict Env.Var -toEffectDups effects = - case effects of - Src.NoEffects -> - Dups.none - - Src.Ports ports -> - let - addPort dict (Src.Port (A.At region name) _) = - Dups.insert name region (Env.TopLevel region) dict - in - List.foldl' addPort Dups.none ports - - Src.Manager _ manager -> - case manager of - Src.Cmd (A.At region _) -> - Dups.one "command" region (Env.TopLevel region) - - Src.Sub (A.At region _) -> - Dups.one "subscription" region (Env.TopLevel region) - - Src.Fx (A.At regionCmd _) (A.At regionSub _) -> - Dups.union - (Dups.one "command" regionCmd (Env.TopLevel regionCmd)) - (Dups.one "subscription" regionSub (Env.TopLevel regionSub)) - - - --- ADD TYPES - - -addTypes :: Src.Module -> Env.Env -> Result i w Env.Env -addTypes (Src.Module _ _ _ _ _ unions aliases _ _) (Env.Env home vs ts cs bs qvs qts qcs) = - let - addAliasDups dups (A.At _ (Src.Alias (A.At region name) _ _)) = Dups.insert name region () dups - addUnionDups dups (A.At _ (Src.Union (A.At region name) _ _)) = Dups.insert name region () dups - typeNameDups = - List.foldl' addUnionDups (List.foldl' addAliasDups Dups.none aliases) unions - in - do _ <- Dups.detect Error.DuplicateType typeNameDups - ts1 <- foldM (addUnion home) ts unions - addAliases aliases (Env.Env home vs ts1 cs bs qvs qts qcs) - - -addUnion :: ModuleName.Canonical -> Env.Exposed Env.Type -> A.Located Src.Union -> Result i w (Env.Exposed Env.Type) -addUnion home types union@(A.At _ (Src.Union (A.At _ name) _ _)) = - do arity <- checkUnionFreeVars union - let one = Map.singleton home (Env.Union arity home) - Result.ok $ Map.insert name one types - - - --- ADD TYPE ALIASES - - -addAliases :: [A.Located Src.Alias] -> Env.Env -> Result i w Env.Env -addAliases aliases env = - let - nodes = map toNode aliases - sccs = Graph.stronglyConnComp nodes - in - foldM addAlias env sccs - - -addAlias :: Env.Env -> Graph.SCC (A.Located Src.Alias) -> Result i w Env.Env -addAlias env@(Env.Env home vs ts cs bs qvs qts qcs) scc = - case scc of - Graph.AcyclicSCC alias@(A.At _ (Src.Alias (A.At _ name) _ tipe)) -> - do args <- checkAliasFreeVars alias - ctype <- Type.canonicalize env tipe - let one = Map.singleton home (Env.Alias (length args) home args ctype) - let ts1 = Map.insert name one ts - Result.ok $ Env.Env home vs ts1 cs bs qvs qts qcs - - Graph.CyclicSCC [] -> - Result.ok env - - Graph.CyclicSCC (alias@(A.At _ (Src.Alias (A.At region name1) _ tipe)) : others) -> - do args <- checkAliasFreeVars alias - let toName (A.At _ (Src.Alias (A.At _ name) _ _)) = name - Result.throw (Error.RecursiveAlias region name1 args tipe (map toName others)) - - - --- DETECT TYPE ALIAS CYCLES - - -toNode :: A.Located Src.Alias -> (A.Located Src.Alias, Name.Name, [Name.Name]) -toNode alias@(A.At _ (Src.Alias (A.At _ name) _ tipe)) = - ( alias, name, getEdges [] tipe ) - - -getEdges :: [Name.Name] -> Src.Type -> [Name.Name] -getEdges edges (A.At _ tipe) = - case tipe of - Src.TLambda arg result -> - getEdges (getEdges edges arg) result - - Src.TVar _ -> - edges - - Src.TType _ name args -> - List.foldl' getEdges (name:edges) args - - Src.TTypeQual _ _ _ args -> - List.foldl' getEdges edges args - - Src.TRecord fields _ -> - List.foldl' (\es (_,t) -> getEdges es t) edges fields - - Src.TUnit -> - edges - - Src.TTuple a b cs -> - List.foldl' getEdges (getEdges (getEdges edges a) b) cs - - - --- CHECK FREE VARIABLES - - -checkUnionFreeVars :: A.Located Src.Union -> Result i w Int -checkUnionFreeVars (A.At unionRegion (Src.Union (A.At _ name) args ctors)) = - let - addArg (A.At region arg) dict = - Dups.insert arg region region dict - - addCtorFreeVars (_, tipes) freeVars = - List.foldl' addFreeVars freeVars tipes - in - do boundVars <- Dups.detect (Error.DuplicateUnionArg name) (foldr addArg Dups.none args) - let freeVars = foldr addCtorFreeVars Map.empty ctors - case Map.toList (Map.difference freeVars boundVars) of - [] -> - Result.ok (length args) - - unbound:unbounds -> - Result.throw $ - Error.TypeVarsUnboundInUnion unionRegion name (map A.toValue args) unbound unbounds - - -checkAliasFreeVars :: A.Located Src.Alias -> Result i w [Name.Name] -checkAliasFreeVars (A.At aliasRegion (Src.Alias (A.At _ name) args tipe)) = - let - addArg (A.At region arg) dict = - Dups.insert arg region region dict - in - do boundVars <- Dups.detect (Error.DuplicateAliasArg name) (foldr addArg Dups.none args) - let freeVars = addFreeVars Map.empty tipe - let overlap = Map.size (Map.intersection boundVars freeVars) - if Map.size boundVars == overlap && Map.size freeVars == overlap - then Result.ok (map A.toValue args) - else - Result.throw $ - Error.TypeVarsMessedUpInAlias aliasRegion name - (map A.toValue args) - (Map.toList (Map.difference boundVars freeVars)) - (Map.toList (Map.difference freeVars boundVars)) - - -addFreeVars :: Map.Map Name.Name A.Region -> Src.Type -> Map.Map Name.Name A.Region -addFreeVars freeVars (A.At region tipe) = - case tipe of - Src.TLambda arg result -> - addFreeVars (addFreeVars freeVars arg) result - - Src.TVar name -> - Map.insert name region freeVars - - Src.TType _ _ args -> - List.foldl' addFreeVars freeVars args - - Src.TTypeQual _ _ _ args -> - List.foldl' addFreeVars freeVars args - - Src.TRecord fields maybeExt -> - let - extFreeVars = - case maybeExt of - Nothing -> - freeVars - - Just (A.At extRegion ext) -> - Map.insert ext extRegion freeVars - in - List.foldl' (\fvs (_,t) -> addFreeVars fvs t) extFreeVars fields - - Src.TUnit -> - freeVars - - Src.TTuple a b cs -> - List.foldl' addFreeVars (addFreeVars (addFreeVars freeVars a) b) cs - - - --- ADD CTORS - - -addCtors :: Src.Module -> Env.Env -> Result i w (Env.Env, Unions, Aliases) -addCtors (Src.Module _ _ _ _ _ unions aliases _ _) env@(Env.Env home vs ts cs bs qvs qts qcs) = - do unionInfo <- traverse (canonicalizeUnion env) unions - aliasInfo <- traverse (canonicalizeAlias env) aliases - - ctors <- - Dups.detect Error.DuplicateCtor $ - Dups.union - (Dups.unions (map snd unionInfo)) - (Dups.unions (map snd aliasInfo)) - - let cs2 = Map.union ctors cs - - Result.ok - ( Env.Env home vs ts cs2 bs qvs qts qcs - , Map.fromList (map fst unionInfo) - , Map.fromList (map fst aliasInfo) - ) - - -type CtorDups = Dups.Dict (Map.Map ModuleName.Canonical Env.Ctor) - - - --- CANONICALIZE ALIAS - - -canonicalizeAlias :: Env.Env -> A.Located Src.Alias -> Result i w ( (Name.Name, Can.Alias), CtorDups ) -canonicalizeAlias env@(Env.Env home _ _ _ _ _ _ _) (A.At _ (Src.Alias (A.At region name) args tipe)) = - do let vars = map A.toValue args - ctipe <- Type.canonicalize env tipe - Result.ok - ( (name, Can.Alias vars ctipe) - , - case ctipe of - Can.TRecord fields Nothing -> - Dups.one name region (Map.singleton home (toRecordCtor home name vars fields)) - - _ -> - Dups.none - ) - -toRecordCtor :: ModuleName.Canonical -> Name.Name -> [Name.Name] -> Map.Map Name.Name Can.FieldType -> Env.Ctor -toRecordCtor home name vars fields = - let - avars = map (\var -> (var, Can.TVar var)) vars - alias = - foldr - (\(_,t1) t2 -> Can.TLambda t1 t2) - (Can.TAlias home name avars (Can.Filled (Can.TRecord fields Nothing))) - (Can.fieldsToList fields) - in - Env.RecordCtor home vars alias - - - --- CANONICALIZE UNION - - -canonicalizeUnion :: Env.Env -> A.Located Src.Union -> Result i w ( (Name.Name, Can.Union), CtorDups ) -canonicalizeUnion env@(Env.Env home _ _ _ _ _ _ _) (A.At _ (Src.Union (A.At _ name) avars ctors)) = - do cctors <- Index.indexedTraverse (canonicalizeCtor env) ctors - let vars = map A.toValue avars - let alts = map A.toValue cctors - let union = Can.Union vars alts (length alts) (toOpts ctors) - Result.ok - ( (name, union) - , Dups.unions $ map (toCtor home name union) cctors - ) - - -canonicalizeCtor :: Env.Env -> Index.ZeroBased -> (A.Located Name.Name, [Src.Type]) -> Result i w (A.Located Can.Ctor) -canonicalizeCtor env index (A.At region ctor, tipes) = - do ctipes <- traverse (Type.canonicalize env) tipes - Result.ok $ A.At region $ - Can.Ctor ctor index (length ctipes) ctipes - - -toOpts :: [(A.Located Name.Name, [Src.Type])] -> Can.CtorOpts -toOpts ctors = - case ctors of - [ (_,[_]) ] -> - Can.Unbox - - _ -> - if all (null . snd) ctors then Can.Enum else Can.Normal - - -toCtor :: ModuleName.Canonical -> Name.Name -> Can.Union -> A.Located Can.Ctor -> CtorDups -toCtor home typeName union (A.At region (Can.Ctor name index _ args)) = - Dups.one name region $ Map.singleton home $ - Env.Ctor home typeName union index args diff --git a/compiler/src/Canonicalize/Expression.hs b/compiler/src/Canonicalize/Expression.hs deleted file mode 100644 index 2e616dfcc8..0000000000 --- a/compiler/src/Canonicalize/Expression.hs +++ /dev/null @@ -1,762 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE OverloadedStrings #-} -module Canonicalize.Expression - ( canonicalize - , FreeLocals - , Uses(..) - , verifyBindings - , gatherTypedArgs - ) - where - - -import Control.Monad (foldM) -import qualified Data.Graph as Graph -import qualified Data.List as List -import qualified Data.Map.Strict as Map -import qualified Data.Map.Strict.Internal as I -import qualified Data.Name as Name - -import qualified AST.Canonical as Can -import qualified AST.Source as Src -import qualified AST.Utils.Binop as Binop -import qualified AST.Utils.Type as Type -import qualified Canonicalize.Environment as Env -import qualified Canonicalize.Environment.Dups as Dups -import qualified Canonicalize.Pattern as Pattern -import qualified Canonicalize.Type as Type -import qualified Data.Index as Index -import qualified Elm.ModuleName as ModuleName -import qualified Elm.Package as Pkg -import qualified Reporting.Annotation as A -import qualified Reporting.Error.Canonicalize as Error -import qualified Reporting.Result as Result -import qualified Reporting.Warning as W - - - --- RESULTS - - -type Result i w a = - Result.Result i w Error.Error a - - -type FreeLocals = - Map.Map Name.Name Uses - - -data Uses = - Uses - { _direct :: {-# UNPACK #-} !Int - , _delayed :: {-# UNPACK #-} !Int - } - - - --- CANONICALIZE - - -canonicalize :: Env.Env -> Src.Expr -> Result FreeLocals [W.Warning] Can.Expr -canonicalize env (A.At region expression) = - A.At region <$> - case expression of - Src.Str string -> - Result.ok (Can.Str string) - - Src.Chr char -> - Result.ok (Can.Chr char) - - Src.Int int -> - Result.ok (Can.Int int) - - Src.Float float -> - Result.ok (Can.Float float) - - Src.Var varType name -> - case varType of - Src.LowVar -> findVar region env name - Src.CapVar -> toVarCtor name <$> Env.findCtor region env name - - Src.VarQual varType prefix name -> - case varType of - Src.LowVar -> findVarQual region env prefix name - Src.CapVar -> toVarCtor name <$> Env.findCtorQual region env prefix name - - Src.List exprs -> - Can.List <$> traverse (canonicalize env) exprs - - Src.Op op -> - do (Env.Binop _ home name annotation _ _) <- Env.findBinop region env op - return (Can.VarOperator op home name annotation) - - Src.Negate expr -> - Can.Negate <$> canonicalize env expr - - Src.Binops ops final -> - A.toValue <$> canonicalizeBinops region env ops final - - Src.Lambda srcArgs body -> - delayedUsage $ - do (args, bindings) <- - Pattern.verify Error.DPLambdaArgs $ - traverse (Pattern.canonicalize env) srcArgs - - newEnv <- - Env.addLocals bindings env - - (cbody, freeLocals) <- - verifyBindings W.Pattern bindings (canonicalize newEnv body) - - return (Can.Lambda args cbody, freeLocals) - - Src.Call func args -> - Can.Call - <$> canonicalize env func - <*> traverse (canonicalize env) args - - Src.If branches finally -> - Can.If - <$> traverse (canonicalizeIfBranch env) branches - <*> canonicalize env finally - - Src.Let defs expr -> - A.toValue <$> canonicalizeLet region env defs expr - - Src.Case expr branches -> - Can.Case - <$> canonicalize env expr - <*> traverse (canonicalizeCaseBranch env) branches - - Src.Accessor field -> - Result.ok $ Can.Accessor field - - Src.Access record field -> - Can.Access - <$> canonicalize env record - <*> Result.ok field - - Src.Update (A.At reg name) fields -> - let - makeCanFields = - Dups.checkFields' (\r t -> Can.FieldUpdate r <$> canonicalize env t) fields - in - Can.Update name - <$> (A.At reg <$> findVar reg env name) - <*> (sequenceA =<< makeCanFields) - - Src.Record fields -> - do fieldDict <- Dups.checkFields fields - Can.Record <$> traverse (canonicalize env) fieldDict - - Src.Unit -> - Result.ok Can.Unit - - Src.Tuple a b cs -> - Can.Tuple - <$> canonicalize env a - <*> canonicalize env b - <*> canonicalizeTupleExtras region env cs - - Src.Shader src tipe -> - Result.ok (Can.Shader src tipe) - - - --- CANONICALIZE TUPLE EXTRAS - - -canonicalizeTupleExtras :: A.Region -> Env.Env -> [Src.Expr] -> Result FreeLocals [W.Warning] (Maybe Can.Expr) -canonicalizeTupleExtras region env extras = - case extras of - [] -> - Result.ok Nothing - - [three] -> - Just <$> canonicalize env three - - _ -> - Result.throw (Error.TupleLargerThanThree region) - - - --- CANONICALIZE IF BRANCH - - -canonicalizeIfBranch :: Env.Env -> (Src.Expr, Src.Expr) -> Result FreeLocals [W.Warning] (Can.Expr, Can.Expr) -canonicalizeIfBranch env (condition, branch) = - (,) - <$> canonicalize env condition - <*> canonicalize env branch - - - --- CANONICALIZE CASE BRANCH - - -canonicalizeCaseBranch :: Env.Env -> (Src.Pattern, Src.Expr) -> Result FreeLocals [W.Warning] Can.CaseBranch -canonicalizeCaseBranch env (pattern, expr) = - directUsage $ - do (cpattern, bindings) <- - Pattern.verify Error.DPCaseBranch $ - Pattern.canonicalize env pattern - newEnv <- Env.addLocals bindings env - - (cexpr, freeLocals) <- - verifyBindings W.Pattern bindings (canonicalize newEnv expr) - - return (Can.CaseBranch cpattern cexpr, freeLocals) - - - --- CANONICALIZE BINOPS - - -canonicalizeBinops :: A.Region -> Env.Env -> [(Src.Expr, A.Located Name.Name)] -> Src.Expr -> Result FreeLocals [W.Warning] Can.Expr -canonicalizeBinops overallRegion env ops final = - let - canonicalizeHelp (expr, A.At region op) = - (,) - <$> canonicalize env expr - <*> Env.findBinop region env op - in - runBinopStepper overallRegion =<< ( - More - <$> traverse canonicalizeHelp ops - <*> canonicalize env final - ) - - -data Step - = Done Can.Expr - | More [(Can.Expr, Env.Binop)] Can.Expr - | Error Env.Binop Env.Binop - - -runBinopStepper :: A.Region -> Step -> Result FreeLocals w Can.Expr -runBinopStepper overallRegion step = - case step of - Done expr -> - Result.ok expr - - More [] expr -> - Result.ok expr - - More ( (expr, op) : rest ) final -> - runBinopStepper overallRegion $ - toBinopStep (toBinop op expr) op rest final - - Error (Env.Binop op1 _ _ _ _ _) (Env.Binop op2 _ _ _ _ _) -> - Result.throw (Error.Binop overallRegion op1 op2) - - -toBinopStep :: (Can.Expr -> Can.Expr) -> Env.Binop -> [(Can.Expr, Env.Binop)] -> Can.Expr -> Step -toBinopStep makeBinop rootOp@(Env.Binop _ _ _ _ rootAssociativity rootPrecedence) middle final = - case middle of - [] -> - Done (makeBinop final) - - ( expr, op@(Env.Binop _ _ _ _ associativity precedence) ) : rest -> - if precedence < rootPrecedence then - - More ((makeBinop expr, op) : rest) final - - else if precedence > rootPrecedence then - - case toBinopStep (toBinop op expr) op rest final of - Done newLast -> - Done (makeBinop newLast) - - More newMiddle newLast -> - toBinopStep makeBinop rootOp newMiddle newLast - - Error a b -> - Error a b - - else - - case (rootAssociativity, associativity) of - (Binop.Left, Binop.Left) -> - toBinopStep (\right -> toBinop op (makeBinop expr) right) op rest final - - (Binop.Right, Binop.Right) -> - toBinopStep (\right -> makeBinop (toBinop op expr right)) op rest final - - (_, _) -> - Error rootOp op - - -toBinop :: Env.Binop -> Can.Expr -> Can.Expr -> Can.Expr -toBinop (Env.Binop op home name annotation _ _) left right = - A.merge left right (Can.Binop op home name annotation left right) - - - --- CANONICALIZE LET - - -canonicalizeLet :: A.Region -> Env.Env -> [A.Located Src.Def] -> Src.Expr -> Result FreeLocals [W.Warning] Can.Expr -canonicalizeLet letRegion env defs body = - directUsage $ - do bindings <- - Dups.detect (Error.DuplicatePattern Error.DPLetBinding) $ - List.foldl' addBindings Dups.none defs - - newEnv <- Env.addLocals bindings env - - verifyBindings W.Def bindings $ - do nodes <- foldM (addDefNodes newEnv) [] defs - cbody <- canonicalize newEnv body - detectCycles letRegion (Graph.stronglyConnComp nodes) cbody - - - --- ADD BINDINGS - - -addBindings :: Dups.Dict A.Region -> A.Located Src.Def -> Dups.Dict A.Region -addBindings bindings (A.At _ def) = - case def of - Src.Define (A.At region name) _ _ _ -> - Dups.insert name region region bindings - - Src.Destruct pattern _ -> - addBindingsHelp bindings pattern - - -addBindingsHelp :: Dups.Dict A.Region -> Src.Pattern -> Dups.Dict A.Region -addBindingsHelp bindings (A.At region pattern) = - case pattern of - Src.PAnything -> - bindings - - Src.PVar name -> - Dups.insert name region region bindings - - Src.PRecord fields -> - let - addField dict (A.At fieldRegion name) = - Dups.insert name fieldRegion fieldRegion dict - in - List.foldl' addField bindings fields - - Src.PUnit -> - bindings - - Src.PTuple a b cs -> - List.foldl' addBindingsHelp bindings (a:b:cs) - - Src.PCtor _ _ patterns -> - List.foldl' addBindingsHelp bindings patterns - - Src.PCtorQual _ _ _ patterns -> - List.foldl' addBindingsHelp bindings patterns - - Src.PList patterns -> - List.foldl' addBindingsHelp bindings patterns - - Src.PCons hd tl -> - addBindingsHelp (addBindingsHelp bindings hd) tl - - Src.PAlias aliasPattern (A.At nameRegion name) -> - Dups.insert name nameRegion nameRegion $ - addBindingsHelp bindings aliasPattern - - Src.PChr _ -> - bindings - - Src.PStr _ -> - bindings - - Src.PInt _ -> - bindings - - - --- BUILD BINDINGS GRAPH - - -type Node = - (Binding, Name.Name, [Name.Name]) - - -data Binding - = Define Can.Def - | Edge (A.Located Name.Name) - | Destruct Can.Pattern Can.Expr - - -addDefNodes :: Env.Env -> [Node] -> A.Located Src.Def -> Result FreeLocals [W.Warning] [Node] -addDefNodes env nodes (A.At _ def) = - case def of - Src.Define aname@(A.At _ name) srcArgs body maybeType -> - case maybeType of - Nothing -> - do (args, argBindings) <- - Pattern.verify (Error.DPFuncArgs name) $ - traverse (Pattern.canonicalize env) srcArgs - - newEnv <- - Env.addLocals argBindings env - - (cbody, freeLocals) <- - verifyBindings W.Pattern argBindings (canonicalize newEnv body) - - let cdef = Can.Def aname args cbody - let node = ( Define cdef, name, Map.keys freeLocals ) - logLetLocals args freeLocals (node:nodes) - - Just tipe -> - do (Can.Forall freeVars ctipe) <- Type.toAnnotation env tipe - ((args, resultType), argBindings) <- - Pattern.verify (Error.DPFuncArgs name) $ - gatherTypedArgs env name srcArgs ctipe Index.first [] - - newEnv <- - Env.addLocals argBindings env - - (cbody, freeLocals) <- - verifyBindings W.Pattern argBindings (canonicalize newEnv body) - - let cdef = Can.TypedDef aname freeVars args cbody resultType - let node = ( Define cdef, name, Map.keys freeLocals ) - logLetLocals args freeLocals (node:nodes) - - Src.Destruct pattern body -> - do (cpattern, _bindings) <- - Pattern.verify Error.DPDestruct $ - Pattern.canonicalize env pattern - - Result.Result $ \fs ws bad good -> - case canonicalize env body of - Result.Result k -> - k Map.empty ws - (\freeLocals warnings errors -> - bad (Map.unionWith combineUses freeLocals fs) warnings errors - ) - (\freeLocals warnings cbody -> - let - names = getPatternNames [] pattern - name = Name.fromManyNames (map A.toValue names) - node = ( Destruct cpattern cbody, name, Map.keys freeLocals ) - in - good - (Map.unionWith combineUses fs freeLocals) - warnings - (List.foldl' (addEdge [name]) (node:nodes) names) - ) - - -logLetLocals :: [arg] -> FreeLocals -> value -> Result FreeLocals w value -logLetLocals args letLocals value = - Result.Result $ \freeLocals warnings _ good -> - good - ( Map.unionWith combineUses freeLocals $ - case args of - [] -> letLocals - _ -> Map.map delayUse letLocals - ) - warnings - value - - -addEdge :: [Name.Name] -> [Node] -> A.Located Name.Name -> [Node] -addEdge edges nodes aname@(A.At _ name) = - (Edge aname, name, edges) : nodes - - -getPatternNames :: [A.Located Name.Name] -> Src.Pattern -> [A.Located Name.Name] -getPatternNames names (A.At region pattern) = - case pattern of - Src.PAnything -> names - Src.PVar name -> A.At region name : names - Src.PRecord fields -> fields ++ names - Src.PAlias ptrn name -> getPatternNames (name : names) ptrn - Src.PUnit -> names - Src.PTuple a b cs -> List.foldl' getPatternNames (getPatternNames (getPatternNames names a) b) cs - Src.PCtor _ _ args -> List.foldl' getPatternNames names args - Src.PCtorQual _ _ _ args -> List.foldl' getPatternNames names args - Src.PList patterns -> List.foldl' getPatternNames names patterns - Src.PCons hd tl -> getPatternNames (getPatternNames names hd) tl - Src.PChr _ -> names - Src.PStr _ -> names - Src.PInt _ -> names - - - --- GATHER TYPED ARGS - - -gatherTypedArgs - :: Env.Env - -> Name.Name - -> [Src.Pattern] - -> Can.Type - -> Index.ZeroBased - -> [(Can.Pattern, Can.Type)] - -> Result Pattern.DupsDict w ([(Can.Pattern, Can.Type)], Can.Type) -gatherTypedArgs env name srcArgs tipe index revTypedArgs = - case srcArgs of - [] -> - return (reverse revTypedArgs, tipe) - - srcArg : otherSrcArgs -> - case Type.iteratedDealias tipe of - Can.TLambda argType resultType -> - do arg <- Pattern.canonicalize env srcArg - gatherTypedArgs env name otherSrcArgs resultType (Index.next index) $ - (arg, argType) : revTypedArgs - - _ -> - let (A.At start _, A.At end _) = (head srcArgs, last srcArgs) in - Result.throw $ - Error.AnnotationTooShort (A.mergeRegions start end) name index (length srcArgs) - - - --- DETECT CYCLES - - -detectCycles :: A.Region -> [Graph.SCC Binding] -> Can.Expr -> Result i w Can.Expr -detectCycles letRegion sccs body = - case sccs of - [] -> - Result.ok body - - scc : subSccs -> - case scc of - Graph.AcyclicSCC binding -> - case binding of - Define def -> - A.At letRegion . Can.Let def <$> detectCycles letRegion subSccs body - - Edge _ -> - detectCycles letRegion subSccs body - - Destruct pattern expr -> - A.At letRegion . Can.LetDestruct pattern expr <$> detectCycles letRegion subSccs body - - Graph.CyclicSCC bindings -> - A.At letRegion <$> - (Can.LetRec - <$> checkCycle bindings [] - <*> detectCycles letRegion subSccs body - ) - - -checkCycle :: [Binding] -> [Can.Def] -> Result i w [Can.Def] -checkCycle bindings defs = - case bindings of - [] -> - Result.ok defs - - binding : otherBindings -> - case binding of - Define def@(Can.Def name args _) -> - if null args then - Result.throw (Error.RecursiveLet name (toNames otherBindings defs)) - else - checkCycle otherBindings (def:defs) - - Define def@(Can.TypedDef name _ args _ _) -> - if null args then - Result.throw (Error.RecursiveLet name (toNames otherBindings defs)) - else - checkCycle otherBindings (def:defs) - - Edge name -> - Result.throw (Error.RecursiveLet name (toNames otherBindings defs)) - - Destruct _ _ -> - -- a Destruct cannot appear in a cycle without any Edge values - -- so we just keep going until we get to the edges - checkCycle otherBindings defs - - -toNames :: [Binding] -> [Can.Def] -> [Name.Name] -toNames bindings revDefs = - case bindings of - [] -> - reverse (map getDefName revDefs) - - binding : otherBindings -> - case binding of - Define def -> getDefName def : toNames otherBindings revDefs - Edge (A.At _ name) -> name : toNames otherBindings revDefs - Destruct _ _ -> toNames otherBindings revDefs - - -getDefName :: Can.Def -> Name.Name -getDefName def = - case def of - Can.Def (A.At _ name) _ _ -> - name - - Can.TypedDef (A.At _ name) _ _ _ _ -> - name - - - --- LOG VARIABLE USES - - -logVar :: Name.Name -> a -> Result FreeLocals w a -logVar name value = - Result.Result $ \freeLocals warnings _ good -> - good (Map.insertWith combineUses name oneDirectUse freeLocals) warnings value - - -{-# NOINLINE oneDirectUse #-} -oneDirectUse :: Uses -oneDirectUse = - Uses 1 0 - - -combineUses :: Uses -> Uses -> Uses -combineUses (Uses a b) (Uses x y) = - Uses (a + x) (b + y) - - -delayUse :: Uses -> Uses -delayUse (Uses direct delayed) = - Uses 0 (direct + delayed) - - - --- MANAGING BINDINGS - - -verifyBindings - :: W.Context - -> Pattern.Bindings - -> Result FreeLocals [W.Warning] value - -> Result info [W.Warning] (value, FreeLocals) -verifyBindings context bindings (Result.Result k) = - Result.Result $ \info warnings bad good -> - k Map.empty warnings - (\_ warnings1 err -> - bad info warnings1 err - ) - (\freeLocals warnings1 value -> - let - outerFreeLocals = - Map.difference freeLocals bindings - - warnings2 = - -- NOTE: Uses Map.size for O(1) lookup. This means there is - -- no dictionary allocation unless a problem is detected. - if Map.size bindings + Map.size outerFreeLocals == Map.size freeLocals then - warnings1 - else - Map.foldlWithKey (addUnusedWarning context) warnings1 $ - Map.difference bindings freeLocals - in - good info warnings2 (value, outerFreeLocals) - ) - - -addUnusedWarning :: W.Context -> [W.Warning] -> Name.Name -> A.Region -> [W.Warning] -addUnusedWarning context warnings name region = - W.UnusedVariable region context name : warnings - - -directUsage :: Result () w (expr, FreeLocals) -> Result FreeLocals w expr -directUsage (Result.Result k) = - Result.Result $ \freeLocals warnings bad good -> - k () warnings - (\() ws es -> bad freeLocals ws es) - (\() ws (value, newFreeLocals) -> - good (Map.unionWith combineUses freeLocals newFreeLocals) ws value - ) - - -delayedUsage :: Result () w (expr, FreeLocals) -> Result FreeLocals w expr -delayedUsage (Result.Result k) = - Result.Result $ \freeLocals warnings bad good -> - k () warnings - (\() ws es -> bad freeLocals ws es) - (\() ws (value, newFreeLocals) -> - let delayedLocals = Map.map delayUse newFreeLocals in - good (Map.unionWith combineUses freeLocals delayedLocals) ws value - ) - - - --- FIND VARIABLE - - -findVar :: A.Region -> Env.Env -> Name.Name -> Result FreeLocals w Can.Expr_ -findVar region (Env.Env localHome vs _ _ _ qvs _ _) name = - case Map.lookup name vs of - Just var -> - case var of - Env.Local _ -> - logVar name (Can.VarLocal name) - - Env.TopLevel _ -> - logVar name (Can.VarTopLevel localHome name) - - Env.Foreign (I.Bin 1 home annotation _ _) -> - Result.ok $ - if home == ModuleName.debug then - Can.VarDebug localHome name annotation - else - Can.VarForeign home name annotation - - Env.Foreign homes -> - Result.throw (Error.AmbiguousVar region Nothing name (Map.keys homes)) - - Nothing -> - Result.throw (Error.NotFoundVar region Nothing name (toPossibleNames vs qvs)) - - -findVarQual :: A.Region -> Env.Env -> Name.Name -> Name.Name -> Result FreeLocals w Can.Expr_ -findVarQual region (Env.Env localHome vs _ _ _ qvs _ _) prefix name = - case Map.lookup prefix qvs of - Just qualified -> - case Map.lookup name qualified of - Just (I.Bin 1 home annotation _ _) -> - Result.ok $ - if home == ModuleName.debug then - Can.VarDebug localHome name annotation - else - Can.VarForeign home name annotation - - Just homes -> - Result.throw (Error.AmbiguousVar region (Just prefix) name (Map.keys homes)) - - Nothing -> - Result.throw (Error.NotFoundVar region (Just prefix) name (toPossibleNames vs qvs)) - - Nothing -> - if Name.isKernel prefix && Pkg.isKernel (ModuleName._package localHome) then - Result.ok $ Can.VarKernel (Name.getKernel prefix) name - else - Result.throw (Error.NotFoundVar region (Just prefix) name (toPossibleNames vs qvs)) - - -toPossibleNames :: Map.Map Name.Name Env.Var -> Env.Qualified Can.Annotation -> Error.PossibleNames -toPossibleNames exposed qualified = - Error.PossibleNames (Map.keysSet exposed) (Map.map Map.keysSet qualified) - - - --- FIND CTOR - - -toVarCtor :: Name.Name -> Env.Ctor -> Can.Expr_ -toVarCtor name ctor = - case ctor of - Env.Ctor home typeName (Can.Union vars _ _ opts) index args -> - let - freeVars = Map.fromList (map (\v -> (v, ())) vars) - result = Can.TType home typeName (map Can.TVar vars) - tipe = foldr Can.TLambda result args - in - Can.VarCtor opts home name index (Can.Forall freeVars tipe) - - Env.RecordCtor home vars tipe -> - let - freeVars = Map.fromList (map (\v -> (v, ())) vars) - in - Can.VarCtor Can.Normal home name Index.first (Can.Forall freeVars tipe) diff --git a/compiler/src/Canonicalize/Module.hs b/compiler/src/Canonicalize/Module.hs deleted file mode 100644 index dd654f51b8..0000000000 --- a/compiler/src/Canonicalize/Module.hs +++ /dev/null @@ -1,296 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -module Canonicalize.Module - ( canonicalize - ) - where - - -import qualified Data.Graph as Graph -import qualified Data.Map as Map -import qualified Data.Name as Name - -import qualified AST.Canonical as Can -import qualified AST.Source as Src -import qualified Canonicalize.Effects as Effects -import qualified Canonicalize.Environment as Env -import qualified Canonicalize.Environment.Dups as Dups -import qualified Canonicalize.Environment.Foreign as Foreign -import qualified Canonicalize.Environment.Local as Local -import qualified Canonicalize.Expression as Expr -import qualified Canonicalize.Pattern as Pattern -import qualified Canonicalize.Type as Type -import qualified Data.Index as Index -import qualified Elm.Interface as I -import qualified Elm.ModuleName as ModuleName -import qualified Elm.Package as Pkg -import qualified Reporting.Annotation as A -import qualified Reporting.Error.Canonicalize as Error -import qualified Reporting.Result as Result -import qualified Reporting.Warning as W - - - --- RESULT - - -type Result i w a = - Result.Result i w Error.Error a - - - --- MODULES - - -canonicalize :: Pkg.Name -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> Result i [W.Warning] Can.Module -canonicalize pkg ifaces modul@(Src.Module _ exports docs imports values _ _ binops effects) = - do let home = ModuleName.Canonical pkg (Src.getName modul) - let cbinops = Map.fromList (map canonicalizeBinop binops) - - (env, cunions, caliases) <- - Local.add modul =<< - Foreign.createInitialEnv home ifaces imports - - cvalues <- canonicalizeValues env values - ceffects <- Effects.canonicalize env values cunions effects - cexports <- canonicalizeExports values cunions caliases cbinops ceffects exports - - return $ Can.Module home cexports docs cvalues cunions caliases cbinops ceffects - - - --- CANONICALIZE BINOP - - -canonicalizeBinop :: A.Located Src.Infix -> ( Name.Name, Can.Binop ) -canonicalizeBinop (A.At _ (Src.Infix op associativity precedence func)) = - ( op, Can.Binop_ associativity precedence func ) - - - --- DECLARATIONS / CYCLE DETECTION --- --- There are two phases of cycle detection: --- --- 1. Detect cycles using ALL dependencies => needed for type inference --- 2. Detect cycles using DIRECT dependencies => nonterminating recursion --- - - -canonicalizeValues :: Env.Env -> [A.Located Src.Value] -> Result i [W.Warning] Can.Decls -canonicalizeValues env values = - do nodes <- traverse (toNodeOne env) values - detectCycles (Graph.stronglyConnComp nodes) - - -detectCycles :: [Graph.SCC NodeTwo] -> Result i w Can.Decls -detectCycles sccs = - case sccs of - [] -> - Result.ok Can.SaveTheEnvironment - - scc : otherSccs -> - case scc of - Graph.AcyclicSCC (def, _, _) -> - Can.Declare def <$> detectCycles otherSccs - - Graph.CyclicSCC subNodes -> - do defs <- traverse detectBadCycles (Graph.stronglyConnComp subNodes) - case defs of - [] -> detectCycles otherSccs - d:ds -> Can.DeclareRec d ds <$> detectCycles otherSccs - - -detectBadCycles :: Graph.SCC Can.Def -> Result i w Can.Def -detectBadCycles scc = - case scc of - Graph.AcyclicSCC def -> - Result.ok def - - Graph.CyclicSCC [] -> - error "The definition of Data.Graph.SCC should not allow empty CyclicSCC!" - - Graph.CyclicSCC (def:defs) -> - let - (A.At region name) = extractDefName def - names = map (A.toValue . extractDefName) defs - in - Result.throw (Error.RecursiveDecl region name names) - - -extractDefName :: Can.Def -> A.Located Name.Name -extractDefName def = - case def of - Can.Def name _ _ -> name - Can.TypedDef name _ _ _ _ -> name - - - --- DECLARATIONS / CYCLE DETECTION SETUP --- --- toNodeOne and toNodeTwo set up nodes for the two cycle detection phases. --- - --- Phase one nodes track ALL dependencies. --- This allows us to find cyclic values for type inference. -type NodeOne = - (NodeTwo, Name.Name, [Name.Name]) - - --- Phase two nodes track DIRECT dependencies. --- This allows us to detect cycles that definitely do not terminate. -type NodeTwo = - (Can.Def, Name.Name, [Name.Name]) - - -toNodeOne :: Env.Env -> A.Located Src.Value -> Result i [W.Warning] NodeOne -toNodeOne env (A.At _ (Src.Value aname@(A.At _ name) srcArgs body maybeType)) = - case maybeType of - Nothing -> - do (args, argBindings) <- - Pattern.verify (Error.DPFuncArgs name) $ - traverse (Pattern.canonicalize env) srcArgs - - newEnv <- - Env.addLocals argBindings env - - (cbody, freeLocals) <- - Expr.verifyBindings W.Pattern argBindings (Expr.canonicalize newEnv body) - - let def = Can.Def aname args cbody - return - ( toNodeTwo name srcArgs def freeLocals - , name - , Map.keys freeLocals - ) - - Just srcType -> - do (Can.Forall freeVars tipe) <- Type.toAnnotation env srcType - - ((args,resultType), argBindings) <- - Pattern.verify (Error.DPFuncArgs name) $ - Expr.gatherTypedArgs env name srcArgs tipe Index.first [] - - newEnv <- - Env.addLocals argBindings env - - (cbody, freeLocals) <- - Expr.verifyBindings W.Pattern argBindings (Expr.canonicalize newEnv body) - - let def = Can.TypedDef aname freeVars args cbody resultType - return - ( toNodeTwo name srcArgs def freeLocals - , name - , Map.keys freeLocals - ) - - -toNodeTwo :: Name.Name -> [arg] -> Can.Def -> Expr.FreeLocals -> NodeTwo -toNodeTwo name args def freeLocals = - case args of - [] -> - (def, name, Map.foldrWithKey addDirects [] freeLocals) - - _ -> - (def, name, []) - - -addDirects :: Name.Name -> Expr.Uses -> [Name.Name] -> [Name.Name] -addDirects name (Expr.Uses directUses _) directDeps = - if directUses > 0 then - name:directDeps - else - directDeps - - - --- CANONICALIZE EXPORTS - - -canonicalizeExports - :: [A.Located Src.Value] - -> Map.Map Name.Name union - -> Map.Map Name.Name alias - -> Map.Map Name.Name binop - -> Can.Effects - -> A.Located Src.Exposing - -> Result i w Can.Exports -canonicalizeExports values unions aliases binops effects (A.At region exposing) = - case exposing of - Src.Open -> - Result.ok (Can.ExportEverything region) - - Src.Explicit exposeds -> - do let names = Map.fromList (map valueToName values) - infos <- traverse (checkExposed names unions aliases binops effects) exposeds - Can.Export <$> Dups.detect Error.ExportDuplicate (Dups.unions infos) - - -valueToName :: A.Located Src.Value -> ( Name.Name, () ) -valueToName (A.At _ (Src.Value (A.At _ name) _ _ _)) = - ( name, () ) - - -checkExposed - :: Map.Map Name.Name value - -> Map.Map Name.Name union - -> Map.Map Name.Name alias - -> Map.Map Name.Name binop - -> Can.Effects - -> Src.Exposed - -> Result i w (Dups.Dict (A.Located Can.Export)) -checkExposed values unions aliases binops effects exposed = - case exposed of - Src.Lower (A.At region name) -> - if Map.member name values then - ok name region Can.ExportValue - else - case checkPorts effects name of - Nothing -> - ok name region Can.ExportPort - - Just ports -> - Result.throw $ Error.ExportNotFound region Error.BadVar name $ - ports ++ Map.keys values - - Src.Operator region name -> - if Map.member name binops then - ok name region Can.ExportBinop - else - Result.throw $ Error.ExportNotFound region Error.BadOp name $ - Map.keys binops - - Src.Upper (A.At region name) (Src.Public dotDotRegion) -> - if Map.member name unions then - ok name region Can.ExportUnionOpen - else if Map.member name aliases then - Result.throw $ Error.ExportOpenAlias dotDotRegion name - else - Result.throw $ Error.ExportNotFound region Error.BadType name $ - Map.keys unions ++ Map.keys aliases - - Src.Upper (A.At region name) Src.Private -> - if Map.member name unions then - ok name region Can.ExportUnionClosed - else if Map.member name aliases then - ok name region Can.ExportAlias - else - Result.throw $ Error.ExportNotFound region Error.BadType name $ - Map.keys unions ++ Map.keys aliases - - -checkPorts :: Can.Effects -> Name.Name -> Maybe [Name.Name] -checkPorts effects name = - case effects of - Can.NoEffects -> - Just [] - - Can.Ports ports -> - if Map.member name ports then Nothing else Just (Map.keys ports) - - Can.Manager _ _ _ _ -> - Just [] - - -ok :: Name.Name -> A.Region -> Can.Export -> Result i w (Dups.Dict (A.Located Can.Export)) -ok name region export = - Result.ok $ Dups.one name region (A.At region export) diff --git a/compiler/src/Canonicalize/Pattern.hs b/compiler/src/Canonicalize/Pattern.hs deleted file mode 100644 index e89b295acf..0000000000 --- a/compiler/src/Canonicalize/Pattern.hs +++ /dev/null @@ -1,180 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -module Canonicalize.Pattern - ( verify - , Bindings - , DupsDict - , canonicalize - ) - where - - -import qualified Data.Map.Strict as Map -import qualified Data.Name as Name - -import qualified AST.Canonical as Can -import qualified AST.Source as Src -import qualified Canonicalize.Environment as Env -import qualified Canonicalize.Environment.Dups as Dups -import qualified Data.Index as Index -import qualified Elm.ModuleName as ModuleName -import qualified Reporting.Annotation as A -import qualified Reporting.Error.Canonicalize as Error -import qualified Reporting.Result as Result - - - --- RESULTS - - -type Result i w a = - Result.Result i w Error.Error a - - -type Bindings = - Map.Map Name.Name A.Region - - - --- VERIFY - - -verify :: Error.DuplicatePatternContext -> Result DupsDict w a -> Result i w (a, Bindings) -verify context (Result.Result k) = - Result.Result $ \info warnings bad good -> - k Dups.none warnings - (\_ warnings1 errors -> - bad info warnings1 errors - ) - (\bindings warnings1 value -> - case Dups.detect (Error.DuplicatePattern context) bindings of - Result.Result k1 -> - k1 () () - (\() () errs -> bad info warnings1 errs) - (\() () dict -> good info warnings1 (value, dict)) - ) - - - --- CANONICALIZE - - -type DupsDict = - Dups.Dict A.Region - - -canonicalize :: Env.Env -> Src.Pattern -> Result DupsDict w Can.Pattern -canonicalize env (A.At region pattern) = - A.At region <$> - case pattern of - Src.PAnything -> - Result.ok Can.PAnything - - Src.PVar name -> - logVar name region (Can.PVar name) - - Src.PRecord fields -> - logFields fields (Can.PRecord (map A.toValue fields)) - - Src.PUnit -> - Result.ok Can.PUnit - - Src.PTuple a b cs -> - Can.PTuple - <$> canonicalize env a - <*> canonicalize env b - <*> canonicalizeTuple region env cs - - Src.PCtor nameRegion name patterns -> - canonicalizeCtor env region name patterns =<< Env.findCtor nameRegion env name - - Src.PCtorQual nameRegion home name patterns -> - canonicalizeCtor env region name patterns =<< Env.findCtorQual nameRegion env home name - - Src.PList patterns -> - Can.PList <$> canonicalizeList env patterns - - Src.PCons first rest -> - Can.PCons - <$> canonicalize env first - <*> canonicalize env rest - - Src.PAlias ptrn (A.At reg name) -> - do cpattern <- canonicalize env ptrn - logVar name reg (Can.PAlias cpattern name) - - Src.PChr chr -> - Result.ok (Can.PChr chr) - - Src.PStr str -> - Result.ok (Can.PStr str) - - Src.PInt int -> - Result.ok (Can.PInt int) - - -canonicalizeCtor :: Env.Env -> A.Region -> Name.Name -> [Src.Pattern] -> Env.Ctor -> Result DupsDict w Can.Pattern_ -canonicalizeCtor env region name patterns ctor = - case ctor of - Env.Ctor home tipe union index args -> - let - toCanonicalArg argIndex argPattern argTipe = - Can.PatternCtorArg argIndex argTipe <$> canonicalize env argPattern - in - do verifiedList <- Index.indexedZipWithA toCanonicalArg patterns args - case verifiedList of - Index.LengthMatch cargs -> - if tipe == Name.bool && home == ModuleName.basics then - Result.ok (Can.PBool union (name == Name.true)) - else - Result.ok (Can.PCtor home tipe union name index cargs) - - Index.LengthMismatch actualLength expectedLength -> - Result.throw (Error.BadArity region Error.PatternArity name expectedLength actualLength) - - Env.RecordCtor _ _ _ -> - Result.throw (Error.PatternHasRecordCtor region name) - - -canonicalizeTuple :: A.Region -> Env.Env -> [Src.Pattern] -> Result DupsDict w (Maybe Can.Pattern) -canonicalizeTuple tupleRegion env extras = - case extras of - [] -> - Result.ok Nothing - - [three] -> - Just <$> canonicalize env three - - _ -> - Result.throw $ Error.TupleLargerThanThree tupleRegion - - -canonicalizeList :: Env.Env -> [Src.Pattern] -> Result DupsDict w [Can.Pattern] -canonicalizeList env list = - case list of - [] -> - Result.ok [] - - pattern : otherPatterns -> - (:) - <$> canonicalize env pattern - <*> canonicalizeList env otherPatterns - - - --- LOG BINDINGS - - -logVar :: Name.Name -> A.Region -> a -> Result DupsDict w a -logVar name region value = - Result.Result $ \bindings warnings _ ok -> - ok (Dups.insert name region region bindings) warnings value - - -logFields :: [A.Located Name.Name] -> a -> Result DupsDict w a -logFields fields value = - let - addField (A.At region name) dict = - Dups.insert name region region dict - in - Result.Result $ \bindings warnings _ ok -> - ok (foldr addField bindings fields) warnings value diff --git a/compiler/src/Canonicalize/Type.hs b/compiler/src/Canonicalize/Type.hs deleted file mode 100644 index ba223d5627..0000000000 --- a/compiler/src/Canonicalize/Type.hs +++ /dev/null @@ -1,162 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE OverloadedStrings #-} -module Canonicalize.Type - ( toAnnotation - , canonicalize - ) - where - - -import qualified Data.List as List -import qualified Data.Map as Map -import qualified Data.Name as Name - -import qualified AST.Canonical as Can -import qualified AST.Source as Src -import qualified Canonicalize.Environment as Env -import qualified Canonicalize.Environment.Dups as Dups -import qualified Reporting.Annotation as A -import qualified Reporting.Error.Canonicalize as Error -import qualified Reporting.Result as Result - - - --- RESULT - - -type Result i w a = - Result.Result i w Error.Error a - - - --- TO ANNOTATION - - -toAnnotation :: Env.Env -> Src.Type -> Result i w Can.Annotation -toAnnotation env srcType = - do tipe <- canonicalize env srcType - Result.ok $ Can.Forall (addFreeVars Map.empty tipe) tipe - - - --- CANONICALIZE TYPES - - -canonicalize :: Env.Env -> Src.Type -> Result i w Can.Type -canonicalize env (A.At typeRegion tipe) = - case tipe of - Src.TVar x -> - Result.ok (Can.TVar x) - - Src.TType region name args -> - canonicalizeType env typeRegion name args =<< - Env.findType region env name - - Src.TTypeQual region home name args -> - canonicalizeType env typeRegion name args =<< - Env.findTypeQual region env home name - - Src.TLambda a b -> - Can.TLambda - <$> canonicalize env a - <*> canonicalize env b - - Src.TRecord fields ext -> - do cfields <- sequenceA =<< Dups.checkFields (canonicalizeFields env fields) - return $ Can.TRecord cfields (fmap A.toValue ext) - - Src.TUnit -> - Result.ok Can.TUnit - - Src.TTuple a b cs -> - Can.TTuple - <$> canonicalize env a - <*> canonicalize env b - <*> - case cs of - [] -> - Result.ok Nothing - - [c] -> - Just <$> canonicalize env c - - _ -> - Result.throw $ Error.TupleLargerThanThree typeRegion - - -canonicalizeFields :: Env.Env -> [(A.Located Name.Name, Src.Type)] -> [(A.Located Name.Name, Result i w Can.FieldType)] -canonicalizeFields env fields = - let - len = fromIntegral (length fields) - canonicalizeField index (name, srcType) = - (name, Can.FieldType index <$> canonicalize env srcType) - in - zipWith canonicalizeField [0..len] fields - - - --- CANONICALIZE TYPE - - -canonicalizeType :: Env.Env -> A.Region -> Name.Name -> [Src.Type] -> Env.Type -> Result i w Can.Type -canonicalizeType env region name args info = - do cargs <- traverse (canonicalize env) args - case info of - Env.Alias arity home argNames aliasedType -> - checkArity arity region name args $ - Can.TAlias home name (zip argNames cargs) (Can.Holey aliasedType) - - Env.Union arity home -> - checkArity arity region name args $ - Can.TType home name cargs - - -checkArity :: Int -> A.Region -> Name.Name -> [A.Located arg] -> answer -> Result i w answer -checkArity expected region name args answer = - let actual = length args in - if expected == actual then - Result.ok answer - else - Result.throw (Error.BadArity region Error.TypeArity name expected actual) - - - --- ADD FREE VARS - - -addFreeVars :: Map.Map Name.Name () -> Can.Type -> Map.Map Name.Name () -addFreeVars freeVars tipe = - case tipe of - Can.TLambda arg result -> - addFreeVars (addFreeVars freeVars result) arg - - Can.TVar var -> - Map.insert var () freeVars - - Can.TType _ _ args -> - List.foldl' addFreeVars freeVars args - - Can.TRecord fields Nothing -> - Map.foldl addFieldFreeVars freeVars fields - - Can.TRecord fields (Just ext) -> - Map.foldl addFieldFreeVars (Map.insert ext () freeVars) fields - - Can.TUnit -> - freeVars - - Can.TTuple a b maybeC -> - case maybeC of - Nothing -> - addFreeVars (addFreeVars freeVars a) b - - Just c -> - addFreeVars (addFreeVars (addFreeVars freeVars a) b) c - - Can.TAlias _ _ args _ -> - List.foldl' (\fvs (_,arg) -> addFreeVars fvs arg) freeVars args - - -addFieldFreeVars :: Map.Map Name.Name () -> Can.FieldType -> Map.Map Name.Name () -addFieldFreeVars freeVars (Can.FieldType _ tipe) = - addFreeVars freeVars tipe diff --git a/compiler/src/Compile.hs b/compiler/src/Compile.hs deleted file mode 100644 index c5b725a19a..0000000000 --- a/compiler/src/Compile.hs +++ /dev/null @@ -1,92 +0,0 @@ -{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-} -module Compile - ( Artifacts(..) - , compile - ) - where - - -import qualified Data.Map as Map -import qualified Data.Name as Name - -import qualified AST.Source as Src -import qualified AST.Canonical as Can -import qualified AST.Optimized as Opt -import qualified Canonicalize.Module as Canonicalize -import qualified Elm.Interface as I -import qualified Elm.ModuleName as ModuleName -import qualified Elm.Package as Pkg -import qualified Nitpick.PatternMatches as PatternMatches -import qualified Optimize.Module as Optimize -import qualified Reporting.Error as E -import qualified Reporting.Result as R -import qualified Reporting.Render.Type.Localizer as Localizer -import qualified Type.Constrain.Module as Type -import qualified Type.Solve as Type - -import System.IO.Unsafe (unsafePerformIO) - - - --- COMPILE - - -data Artifacts = - Artifacts - { _modul :: Can.Module - , _types :: Map.Map Name.Name Can.Annotation - , _graph :: Opt.LocalGraph - } - - -compile :: Pkg.Name -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> Either E.Error Artifacts -compile pkg ifaces modul = - do canonical <- canonicalize pkg ifaces modul - annotations <- typeCheck modul canonical - () <- nitpick canonical - objects <- optimize modul annotations canonical - return (Artifacts canonical annotations objects) - - - --- PHASES - - -canonicalize :: Pkg.Name -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> Either E.Error Can.Module -canonicalize pkg ifaces modul = - case snd $ R.run $ Canonicalize.canonicalize pkg ifaces modul of - Right canonical -> - Right canonical - - Left errors -> - Left $ E.BadNames errors - - -typeCheck :: Src.Module -> Can.Module -> Either E.Error (Map.Map Name.Name Can.Annotation) -typeCheck modul canonical = - case unsafePerformIO (Type.run =<< Type.constrain canonical) of - Right annotations -> - Right annotations - - Left errors -> - Left (E.BadTypes (Localizer.fromModule modul) errors) - - -nitpick :: Can.Module -> Either E.Error () -nitpick canonical = - case PatternMatches.check canonical of - Right () -> - Right () - - Left errors -> - Left (E.BadPatterns errors) - - -optimize :: Src.Module -> Map.Map Name.Name Can.Annotation -> Can.Module -> Either E.Error Opt.LocalGraph -optimize modul annotations canonical = - case snd $ R.run $ Optimize.optimize annotations canonical of - Right localGraph -> - Right localGraph - - Left errors -> - Left (E.BadMains (Localizer.fromModule modul) errors) diff --git a/compiler/src/Data/Bag.hs b/compiler/src/Data/Bag.hs deleted file mode 100644 index 4fd34c945e..0000000000 --- a/compiler/src/Data/Bag.hs +++ /dev/null @@ -1,110 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -module Data.Bag - ( Bag(..) - , empty - , one - , append - , map - , toList - , fromList - ) - where - - -import Prelude hiding (map) -import qualified Data.List as List - - - --- BAGS - - -data Bag a - = Empty - | One a - | Two (Bag a) (Bag a) - - - --- HELPERS - - -empty :: Bag a -empty = - Empty - - -one :: a -> Bag a -one = - One - - -append :: Bag a -> Bag a -> Bag a -append left right = - case (left, right) of - (other, Empty) -> - other - - (Empty, other) -> - other - - (_, _) -> - Two left right - - - --- MAP - - -map :: (a -> b) -> Bag a -> Bag b -map func bag = - case bag of - Empty -> - Empty - - One a -> - One (func a) - - Two left right -> - Two (map func left) (map func right) - - - --- TO LIST - - -toList :: Bag a -> [a] -toList bag = - toListHelp bag [] - - -toListHelp :: Bag a -> [a] -> [a] -toListHelp bag list = - case bag of - Empty -> - list - - One x -> - x : list - - Two a b -> - toListHelp a (toListHelp b list) - - - --- FROM LIST - - -fromList :: (a -> b) -> [a] -> Bag b -fromList func list = - case list of - [] -> - Empty - - first : rest -> - List.foldl' (add func) (One (func first)) rest - - -add :: (a -> b) -> Bag b -> a -> Bag b -add func bag value = - Two (One (func value)) bag diff --git a/compiler/src/Data/Index.hs b/compiler/src/Data/Index.hs deleted file mode 100644 index ff4e625bb5..0000000000 --- a/compiler/src/Data/Index.hs +++ /dev/null @@ -1,132 +0,0 @@ -module Data.Index - ( ZeroBased - , first - , second - , third - , next - , toMachine - , toHuman - , indexedMap - , indexedTraverse - , indexedForA - , VerifiedList(..) - , indexedZipWith - , indexedZipWithA - ) - where - - -import Control.Monad (liftM) -import Data.Binary - - - --- ZERO BASED - - -newtype ZeroBased = ZeroBased Int - deriving (Eq, Ord) - - -first :: ZeroBased -first = - ZeroBased 0 - - -second :: ZeroBased -second = - ZeroBased 1 - - -third :: ZeroBased -third = - ZeroBased 2 - - -{-# INLINE next #-} -next :: ZeroBased -> ZeroBased -next (ZeroBased i) = - ZeroBased (i + 1) - - - --- DESTRUCT - - -toMachine :: ZeroBased -> Int -toMachine (ZeroBased index) = - index - - -toHuman :: ZeroBased -> Int -toHuman (ZeroBased index) = - index + 1 - - - --- INDEXED MAP - - -{-# INLINE indexedMap #-} -indexedMap :: (ZeroBased -> a -> b) -> [a] -> [b] -indexedMap func xs = - zipWith func (map ZeroBased [0 .. length xs]) xs - - -{-# INLINE indexedTraverse #-} -indexedTraverse :: (Applicative f) => (ZeroBased -> a -> f b) -> [a] -> f [b] -indexedTraverse func xs = - sequenceA (indexedMap func xs) - - -{-# INLINE indexedForA #-} -indexedForA :: (Applicative f) => [a] -> (ZeroBased -> a -> f b) -> f [b] -indexedForA xs func = - sequenceA (indexedMap func xs) - - - --- VERIFIED/INDEXED ZIP - - -data VerifiedList a - = LengthMatch [a] - | LengthMismatch Int Int - - -indexedZipWith :: (ZeroBased -> a -> b -> c) -> [a] -> [b] -> VerifiedList c -indexedZipWith func listX listY = - indexedZipWithHelp func 0 listX listY [] - - -indexedZipWithHelp :: (ZeroBased -> a -> b -> c) -> Int -> [a] -> [b] -> [c] -> VerifiedList c -indexedZipWithHelp func index listX listY revListZ = - case (listX, listY) of - ([], []) -> - LengthMatch (reverse revListZ) - - (x:xs, y:ys) -> - indexedZipWithHelp func (index + 1) xs ys $ - func (ZeroBased index) x y : revListZ - - (_, _) -> - LengthMismatch (index + length listX) (index + length listY) - - -indexedZipWithA :: (Applicative f) => (ZeroBased -> a -> b -> f c) -> [a] -> [b] -> f (VerifiedList c) -indexedZipWithA func listX listY = - case indexedZipWith func listX listY of - LengthMatch xs -> - LengthMatch <$> sequenceA xs - - LengthMismatch x y -> - pure (LengthMismatch x y) - - - --- BINARY - - -instance Binary ZeroBased where - get = liftM ZeroBased get - put (ZeroBased n) = put n diff --git a/compiler/src/Data/Map/Utils.hs b/compiler/src/Data/Map/Utils.hs deleted file mode 100644 index e369101d27..0000000000 --- a/compiler/src/Data/Map/Utils.hs +++ /dev/null @@ -1,43 +0,0 @@ -module Data.Map.Utils - ( fromKeys - , fromKeysA - , fromValues - , any - ) - where - - -import Prelude hiding (any) -import qualified Data.Map as Map -import Data.Map.Internal (Map(..)) - - - --- FROM KEYS - - -fromKeys :: (Ord k) => (k -> v) -> [k] -> Map.Map k v -fromKeys toValue keys = - Map.fromList $ map (\k -> (k, toValue k)) keys - - -fromKeysA :: (Applicative f, Ord k) => (k -> f v) -> [k] -> f (Map.Map k v) -fromKeysA toValue keys = - Map.fromList <$> traverse (\k -> (,) k <$> toValue k) keys - - -fromValues :: (Ord k) => (v -> k) -> [v] -> Map.Map k v -fromValues toKey values = - Map.fromList $ map (\v -> (toKey v, v)) values - - - --- ANY - - -{-# INLINE any #-} -any :: (v -> Bool) -> Map.Map k v -> Bool -any isGood = go - where - go Tip = False - go (Bin _ _ v l r) = isGood v || go l || go r diff --git a/compiler/src/Data/Name.hs b/compiler/src/Data/Name.hs deleted file mode 100644 index beecf114c4..0000000000 --- a/compiler/src/Data/Name.hs +++ /dev/null @@ -1,610 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-name-shadowing #-} -{-# LANGUAGE BangPatterns, EmptyDataDecls, FlexibleInstances, MagicHash, UnboxedTuples #-} -module Data.Name - ( Name - -- - , toChars - , toElmString - , toBuilder - -- - , fromPtr - , fromChars - -- - , getKernel - , hasDot - , splitDots - , isKernel - , isNumberType - , isComparableType - , isAppendableType - , isCompappendType - , fromVarIndex - , fromWords - , fromManyNames - , fromTypeVariable - , fromTypeVariableScheme - , sepBy - -- - , int, float, bool, char, string - , maybe, result, list, array, dict, tuple, jsArray - , task, router, cmd, sub, platform, virtualDom - , shader, debug, debugger, bitwise, basics - , utils, negate, true, false, value - , node, program, _main, _Main, dollar, identity - , replModule, replValueToPrint - ) - where - - -import Prelude hiding (length, maybe, negate) -import Control.Exception (assert) -import qualified Data.Binary as Binary -import qualified Data.ByteString.Builder.Internal as B -import qualified Data.Coerce as Coerce -import qualified Data.List as List -import qualified Data.String as Chars -import qualified Data.Utf8 as Utf8 -import GHC.Exts - ( Int(I#), Ptr - , MutableByteArray# - , isTrue# - , newByteArray# - , sizeofByteArray# - , unsafeFreezeByteArray# - ) -import GHC.ST (ST(ST), runST) -import GHC.Prim -import GHC.Word (Word8(W8#)) - -import qualified Elm.String as ES - - - --- NAME - - -type Name = - Utf8.Utf8 ELM_NAME - - -data ELM_NAME - - - --- INSTANCES - - -instance Chars.IsString (Utf8.Utf8 ELM_NAME) where - fromString = Utf8.fromChars - -instance Binary.Binary (Utf8.Utf8 ELM_NAME) where - get = Utf8.getUnder256 - put = Utf8.putUnder256 - - - --- TO - - -toChars :: Name -> [Char] -toChars = - Utf8.toChars - - -toElmString :: Name -> ES.String -toElmString = - Coerce.coerce - - -{-# INLINE toBuilder #-} -toBuilder :: Name -> B.Builder -toBuilder = - Utf8.toBuilder - - - --- FROM - - -fromPtr :: Ptr Word8 -> Ptr Word8 -> Name -fromPtr = - Utf8.fromPtr - - -fromChars :: [Char] -> Name -fromChars = - Utf8.fromChars - - - --- HAS DOT - - -hasDot :: Name -> Bool -hasDot name = - Utf8.contains 0x2E {- . -} name - - -splitDots :: Name -> [Name] -splitDots name = - Utf8.split 0x2E {- . -} name - - - --- GET KERNEL - - -getKernel :: Name -> Name -getKernel name@(Utf8.Utf8 ba#) = - assert (isKernel name) - ( - runST - ( - let - !size# = sizeofByteArray# ba# -# 11# - in - ST $ \s -> - case newByteArray# size# s of - (# s, mba# #) -> - case copyByteArray# ba# 11# mba# 0# size# s of - s -> - case unsafeFreezeByteArray# mba# s of - (# s, ba# #) -> (# s, Utf8.Utf8 ba# #) - ) - ) - - - --- STARTS WITH - - -isKernel :: Name -> Bool -isKernel = Utf8.startsWith prefix_kernel - -isNumberType :: Name -> Bool -isNumberType = Utf8.startsWith prefix_number - -isComparableType :: Name -> Bool -isComparableType = Utf8.startsWith prefix_comparable - -isAppendableType :: Name -> Bool -isAppendableType = Utf8.startsWith prefix_appendable - -isCompappendType :: Name -> Bool -isCompappendType = Utf8.startsWith prefix_compappend - -{-# NOINLINE prefix_kernel #-} -prefix_kernel :: Name -prefix_kernel = fromChars "Elm.Kernel." - -{-# NOINLINE prefix_number #-} -prefix_number :: Name -prefix_number = fromChars "number" - -{-# NOINLINE prefix_comparable #-} -prefix_comparable :: Name -prefix_comparable = fromChars "comparable" - -{-# NOINLINE prefix_appendable #-} -prefix_appendable :: Name -prefix_appendable = fromChars "appendable" - -{-# NOINLINE prefix_compappend #-} -prefix_compappend :: Name -prefix_compappend = fromChars "compappend" - - - --- FROM VAR INDEX - - -fromVarIndex :: Int -> Name -fromVarIndex n = - runST - ( - do let !size = 2 + getIndexSize n - mba <- newByteArray size - writeWord8 mba 0 0x5F {- _ -} - writeWord8 mba 1 0x76 {- v -} - writeDigitsAtEnd mba size n - freeze mba - ) - - -{-# INLINE getIndexSize #-} -getIndexSize :: Int -> Int -getIndexSize n - | n < 10 = 1 - | n < 100 = 2 - | True = ceiling (logBase 10 (fromIntegral n + 1) :: Float) - - - -writeDigitsAtEnd :: MBA s -> Int -> Int -> ST s () -writeDigitsAtEnd !mba !oldOffset !n = - do let (q,r) = quotRem n 10 - let !newOffset = oldOffset - 1 - writeWord8 mba newOffset (0x30 + fromIntegral r) - if q <= 0 - then return () - else writeDigitsAtEnd mba newOffset q - - - --- FROM TYPE VARIABLE - - -fromTypeVariable :: Name -> Int -> Name -fromTypeVariable name@(Utf8.Utf8 ba#) index = - if index <= 0 then - name - else - let - len# = sizeofByteArray# ba# - end# = indexWord8Array# ba# (len# -# 1#) - in - if isTrue# (leWord# 0x30## end#) && isTrue# (leWord# end# 0x39##) then - runST - ( - do let !size = I# len# + 1 + getIndexSize index - mba <- newByteArray size - copyToMBA name mba - writeWord8 mba (I# len#) 0x5F {- _ -} - writeDigitsAtEnd mba size index - freeze mba - ) - else - runST - ( - do let !size = I# len# + getIndexSize index - mba <- newByteArray size - copyToMBA name mba - writeDigitsAtEnd mba size index - freeze mba - ) - - - --- FROM TYPE VARIABLE SCHEME - - -fromTypeVariableScheme :: Int -> Name -fromTypeVariableScheme scheme = - runST - ( - if scheme < 26 then - do mba <- newByteArray 1 - writeWord8 mba 0 (0x61 + fromIntegral scheme) - freeze mba - else - do let (extra, letter) = quotRem scheme 26 - let !size = 1 + getIndexSize extra - mba <- newByteArray size - writeWord8 mba 0 (0x61 + fromIntegral letter) - writeDigitsAtEnd mba size extra - freeze mba - ) - - - --- FROM MANY NAMES --- --- Creating a unique name by combining all the subnames can create names --- longer than 256 bytes relatively easily. So instead, the first given name --- (e.g. foo) is prefixed chars that are valid in JS but not Elm (e.g. _M$foo) --- --- This should be a unique name since 0.19 disallows shadowing. It would not --- be possible for multiple top-level cycles to include values with the same --- name, so the important thing is to make the cycle name distinct from the --- normal name. Same logic for destructuring patterns like (x,y) - - -fromManyNames :: [Name] -> Name -fromManyNames names = - case names of - [] -> - blank - -- NOTE: this case is needed for (let _ = Debug.log "x" x in ...) - -- but maybe unused patterns should be stripped out instead - - Utf8.Utf8 ba# : _ -> - let - len# = sizeofByteArray# ba# - in - runST - ( - ST $ \s -> - case newByteArray# (len# +# 3#) s of - (# s, mba# #) -> - case writeWord8Array# mba# 0# 0x5F## {-_-} s of - s -> - case writeWord8Array# mba# 1# 0x4D## {-M-} s of - s -> - case writeWord8Array# mba# 2# 0x24## {-$-} s of - s -> - case copyByteArray# ba# 0# mba# 3# len# s of - s -> - case unsafeFreezeByteArray# mba# s of - (# s, ba# #) -> (# s, Utf8.Utf8 ba# #) - ) - - -{-# NOINLINE blank #-} -blank :: Name -blank = - fromWords [0x5F,0x4D,0x24] {-_M$-} - - - --- FROM WORDS - - -fromWords :: [Word8] -> Name -fromWords words = - runST - ( - do mba <- newByteArray (List.length words) - writeWords mba 0 words - freeze mba - ) - - -writeWords :: MBA s -> Int -> [Word8] -> ST s () -writeWords !mba !i words = - case words of - [] -> - return () - - w:ws -> - do writeWord8 mba i w - writeWords mba (i+1) ws - - - --- SEP BY - - -sepBy :: Word8 -> Name -> Name -> Name -sepBy (W8# sep#) (Utf8.Utf8 ba1#) (Utf8.Utf8 ba2#) = - let - !len1# = sizeofByteArray# ba1# - !len2# = sizeofByteArray# ba2# - in - runST - ( - ST $ \s -> - case newByteArray# (len1# +# len2# +# 1#) s of - (# s, mba# #) -> - case copyByteArray# ba1# 0# mba# 0# len1# s of - s -> - case writeWord8Array# mba# len1# sep# s of - s -> - case copyByteArray# ba2# 0# mba# (len1# +# 1#) len2# s of - s -> - case unsafeFreezeByteArray# mba# s of - (# s, ba# #) -> (# s, Utf8.Utf8 ba# #) - ) - - - --- PRIMITIVES - - -data MBA s = - MBA# (MutableByteArray# s) - - -{-# INLINE newByteArray #-} -newByteArray :: Int -> ST s (MBA s) -newByteArray (I# len#) = - ST $ \s -> - case newByteArray# len# s of - (# s, mba# #) -> (# s, MBA# mba# #) - - -{-# INLINE freeze #-} -freeze :: MBA s -> ST s Name -freeze (MBA# mba#) = - ST $ \s -> - case unsafeFreezeByteArray# mba# s of - (# s, ba# #) -> (# s, Utf8.Utf8 ba# #) - - -{-# INLINE writeWord8 #-} -writeWord8 :: MBA s -> Int -> Word8 -> ST s () -writeWord8 (MBA# mba#) (I# offset#) (W8# w#) = - ST $ \s -> - case writeWord8Array# mba# offset# w# s of - s -> (# s, () #) - - -{-# INLINE copyToMBA #-} -copyToMBA :: Name -> MBA s -> ST s () -copyToMBA (Utf8.Utf8 ba#) (MBA# mba#) = - ST $ \s -> - case copyByteArray# ba# 0# mba# 0# (sizeofByteArray# ba#) s of - s -> (# s, () #) - - - --- COMMON NAMES - - -{-# NOINLINE int #-} -int :: Name -int = fromChars "Int" - - -{-# NOINLINE float #-} -float :: Name -float = fromChars "Float" - - -{-# NOINLINE bool #-} -bool :: Name -bool = fromChars "Bool" - - -{-# NOINLINE char #-} -char :: Name -char = fromChars "Char" - - -{-# NOINLINE string #-} -string :: Name -string = fromChars "String" - - -{-# NOINLINE maybe #-} -maybe :: Name -maybe = fromChars "Maybe" - - -{-# NOINLINE result #-} -result :: Name -result = fromChars "Result" - - -{-# NOINLINE list #-} -list :: Name -list = fromChars "List" - - -{-# NOINLINE array #-} -array :: Name -array = fromChars "Array" - - -{-# NOINLINE dict #-} -dict :: Name -dict = fromChars "Dict" - - -{-# NOINLINE tuple #-} -tuple :: Name -tuple = fromChars "Tuple" - - -{-# NOINLINE jsArray #-} -jsArray :: Name -jsArray = fromChars "JsArray" - - -{-# NOINLINE task #-} -task :: Name -task = fromChars "Task" - - -{-# NOINLINE router #-} -router :: Name -router = fromChars "Router" - - -{-# NOINLINE cmd #-} -cmd :: Name -cmd = fromChars "Cmd" - - -{-# NOINLINE sub #-} -sub :: Name -sub = fromChars "Sub" - - -{-# NOINLINE platform #-} -platform :: Name -platform = fromChars "Platform" - - -{-# NOINLINE virtualDom #-} -virtualDom :: Name -virtualDom = fromChars "VirtualDom" - - -{-# NOINLINE shader #-} -shader :: Name -shader = fromChars "Shader" - - -{-# NOINLINE debug #-} -debug :: Name -debug = fromChars "Debug" - - -{-# NOINLINE debugger #-} -debugger :: Name -debugger = fromChars "Debugger" - - -{-# NOINLINE bitwise #-} -bitwise :: Name -bitwise = fromChars "Bitwise" - - -{-# NOINLINE basics #-} -basics :: Name -basics = fromChars "Basics" - - -{-# NOINLINE utils #-} -utils :: Name -utils = fromChars "Utils" - - -{-# NOINLINE negate #-} -negate :: Name -negate = fromChars "negate" - - -{-# NOINLINE true #-} -true :: Name -true = fromChars "True" - - -{-# NOINLINE false #-} -false :: Name -false = fromChars "False" - - -{-# NOINLINE value #-} -value :: Name -value = fromChars "Value" - - -{-# NOINLINE node #-} -node :: Name -node = fromChars "Node" - - -{-# NOINLINE program #-} -program :: Name -program = fromChars "Program" - - -{-# NOINLINE _main #-} -_main :: Name -_main = fromChars "main" - - -{-# NOINLINE _Main #-} -_Main :: Name -_Main = fromChars "Main" - - -{-# NOINLINE dollar #-} -dollar :: Name -dollar = fromChars "$" - - -{-# NOINLINE identity #-} -identity :: Name -identity = fromChars "identity" - - -{-# NOINLINE replModule #-} -replModule :: Name -replModule = fromChars "Elm_Repl" - - -{-# NOINLINE replValueToPrint #-} -replValueToPrint :: Name -replValueToPrint = fromChars "repl_input_value_" diff --git a/compiler/src/Data/NonEmptyList.hs b/compiler/src/Data/NonEmptyList.hs deleted file mode 100644 index a0445787f3..0000000000 --- a/compiler/src/Data/NonEmptyList.hs +++ /dev/null @@ -1,78 +0,0 @@ -module Data.NonEmptyList - ( List(..) - , singleton - , toList - , sortBy - ) - where - - -import Control.Monad (liftM2) -import Data.Binary (Binary, get, put) -import qualified Data.List as List - - - --- LIST - - -data List a = - List a [a] - - -singleton :: a -> List a -singleton a = - List a [] - - -toList :: List a -> [a] -toList (List x xs) = - x:xs - - - --- INSTANCES - - -instance Functor List where - fmap func (List x xs) = List (func x) (map func xs) - - -instance Traversable List where - traverse func (List x xs) = List <$> func x <*> traverse func xs - - -instance Foldable List where - foldr step state (List x xs) = step x (foldr step state xs) - foldl step state (List x xs) = foldl step (step state x) xs - foldl1 step (List x xs) = foldl step x xs - - - --- SORT BY - - -sortBy :: (Ord b) => (a -> b) -> List a -> List a -sortBy toRank (List x xs) = - let - comparison a b = - compare (toRank a) (toRank b) - in - case List.sortBy comparison xs of - [] -> - List x [] - - y:ys -> - case comparison x y of - LT -> List x (y:ys) - EQ -> List x (y:ys) - GT -> List y (List.insertBy comparison x ys) - - - --- BINARY - - -instance (Binary a) => Binary (List a) where - put (List x xs) = put x >> put xs - get = liftM2 List get get diff --git a/compiler/src/Data/OneOrMore.hs b/compiler/src/Data/OneOrMore.hs deleted file mode 100644 index 0606f799ff..0000000000 --- a/compiler/src/Data/OneOrMore.hs +++ /dev/null @@ -1,99 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -module Data.OneOrMore - ( OneOrMore(..) - , one - , more - , map - , destruct - , getFirstTwo - ) - where - - -import Prelude hiding (map) - - - --- ONE OR MORE - - -data OneOrMore a - = One a - | More (OneOrMore a) (OneOrMore a) - - -one :: a -> OneOrMore a -one = - One - - -more :: OneOrMore a -> OneOrMore a -> OneOrMore a -more = - More - - - --- MAP - - -map :: (a -> b) -> OneOrMore a -> OneOrMore b -map func oneOrMore = - case oneOrMore of - One value -> - One (func value) - - More left right -> - More (map func left) (map func right) - - - --- DESTRUCT - - -destruct :: (a -> [a] -> b) -> OneOrMore a -> b -destruct func oneOrMore = - destructLeft func oneOrMore [] - - -destructLeft :: (a -> [a] -> b) -> OneOrMore a -> [a] -> b -destructLeft func oneOrMore xs = - case oneOrMore of - One x -> - func x xs - - More a b -> - destructLeft func a (destructRight b xs) - - -destructRight :: OneOrMore a -> [a] -> [a] -destructRight oneOrMore xs = - case oneOrMore of - One x -> - x : xs - - More a b -> - destructRight a (destructRight b xs) - - - --- GET FIRST TWO - - -getFirstTwo :: OneOrMore a -> OneOrMore a -> (a,a) -getFirstTwo left right = - case left of - One x -> - (x, getFirstOne right) - - More lleft lright -> - getFirstTwo lleft lright - - -getFirstOne :: OneOrMore a -> a -getFirstOne oneOrMore = - case oneOrMore of - One x -> - x - - More left _ -> - getFirstOne left diff --git a/compiler/src/Data/Utf8.hs b/compiler/src/Data/Utf8.hs deleted file mode 100644 index e985aa6477..0000000000 --- a/compiler/src/Data/Utf8.hs +++ /dev/null @@ -1,616 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-name-shadowing #-} -{-# LANGUAGE BangPatterns, FlexibleInstances, MagicHash, UnboxedTuples #-} -module Data.Utf8 - ( Utf8(..) - , isEmpty - , empty - , size - , contains - , startsWith - , startsWithChar - , endsWithWord8 - , split - , join - -- - , getUnder256 - , putUnder256 - -- - , getVeryLong - , putVeryLong - -- - , toChars - , toBuilder - , toEscapedBuilder - -- - , fromPtr - , fromSnippet - , fromChars - -- - , MBA - , newByteArray - , copyFromPtr - , writeWord8 - , freeze - ) - where - - -import Prelude hiding (String, all, any, concat) -import Data.Binary (Get, get, getWord8, Put, put, putWord8) -import Data.Binary.Put (putBuilder) -import Data.Binary.Get.Internal (readN) -import Data.Bits ((.&.), shiftR) -import qualified Data.ByteString.Internal as B -import qualified Data.ByteString.Builder.Internal as B -import qualified Data.Char as Char -import qualified Data.List as List -import Foreign.ForeignPtr (touchForeignPtr) -import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr) -import Foreign.Ptr (minusPtr, plusPtr) -import GHC.Exts - ( Int(I#), Ptr(Ptr), Char(C#) - , RealWorld - , ByteArray#, MutableByteArray# - , isTrue# - , newByteArray# - , unsafeFreezeByteArray# - , sizeofByteArray# - , copyByteArray# - , copyAddrToByteArray# - , copyByteArrayToAddr# - , writeWord8Array# - ) -import GHC.IO -import GHC.ST (ST(ST), runST) -import GHC.Prim -import GHC.Word (Word8(W8#)) - -import qualified Parse.Primitives as P - - - --- UTF-8 - - -data Utf8 tipe = - Utf8 ByteArray# - - - --- EMPTY - - -{-# NOINLINE empty #-} -empty :: Utf8 t -empty = - runST (freeze =<< newByteArray 0) - - -isEmpty :: Utf8 t -> Bool -isEmpty (Utf8 ba#) = - isTrue# (sizeofByteArray# ba# ==# 0#) - - - --- SIZE - - -size :: Utf8 t -> Int -size (Utf8 ba#) = - I# (sizeofByteArray# ba#) - - - --- CONTAINS - - -contains :: Word8 -> Utf8 t -> Bool -contains (W8# word#) (Utf8 ba#) = - containsHelp word# ba# 0# (sizeofByteArray# ba#) - - -containsHelp :: Word# -> ByteArray# -> Int# -> Int# -> Bool -containsHelp word# ba# !offset# len# = - if isTrue# (offset# <# len#) then - if isTrue# (eqWord# word# (indexWord8Array# ba# offset#)) - then True - else containsHelp word# ba# (offset# +# 1#) len# - else - False - - - --- STARTS WITH - - -{-# INLINE startsWith #-} -startsWith :: Utf8 t -> Utf8 t -> Bool -startsWith (Utf8 ba1#) (Utf8 ba2#) = - let - !len1# = sizeofByteArray# ba1# - !len2# = sizeofByteArray# ba2# - in - isTrue# (len1# <=# len2#) - && - isTrue# (0# ==# compareByteArrays# ba1# 0# ba2# 0# len1#) - - - --- STARTS WITH CHAR - - -startsWithChar :: (Char -> Bool) -> Utf8 t -> Bool -startsWithChar isGood bytes@(Utf8 ba#) = - if isEmpty bytes then - False - else - let - !w# = indexWord8Array# ba# 0# - !char - | isTrue# (ltWord# w# 0xC0##) = C# (chr# (word2Int# w#)) - | isTrue# (ltWord# w# 0xE0##) = chr2 ba# 0# w# - | isTrue# (ltWord# w# 0xF0##) = chr3 ba# 0# w# - | True = chr4 ba# 0# w# - in - isGood char - - - --- ENDS WITH WORD - - -endsWithWord8 :: Word8 -> Utf8 t -> Bool -endsWithWord8 (W8# w#) (Utf8 ba#) = - let len# = sizeofByteArray# ba# in - isTrue# (len# ># 0#) - && - isTrue# (eqWord# w# (indexWord8Array# ba# (len# -# 1#))) - - - --- SPLIT - - -split :: Word8 -> Utf8 t -> [Utf8 t] -split (W8# divider#) str@(Utf8 ba#) = - splitHelp str 0 (findDividers divider# ba# 0# (sizeofByteArray# ba#) []) - - -splitHelp :: Utf8 t -> Int -> [Int] -> [Utf8 t] -splitHelp str start offsets = - case offsets of - [] -> - [ unsafeSlice str start (size str) ] - - offset : offsets -> - unsafeSlice str start offset : splitHelp str (offset + 1) offsets - - -findDividers :: Word# -> ByteArray# -> Int# -> Int# -> [Int] -> [Int] -findDividers divider# ba# !offset# len# revOffsets = - if isTrue# (offset# <# len#) then - findDividers divider# ba# (offset# +# 1#) len# $ - if isTrue# (eqWord# divider# (indexWord8Array# ba# offset#)) - then I# offset# : revOffsets - else revOffsets - else - reverse revOffsets - - -unsafeSlice :: Utf8 t -> Int -> Int -> Utf8 t -unsafeSlice str start end = - let !len = end - start in - if len == 0 then - empty - else - runST $ - do mba <- newByteArray len - copy str start mba 0 len - freeze mba - - - --- JOIN - - -join :: Word8 -> [Utf8 t] -> Utf8 t -join sep strings = - case strings of - [] -> - empty - - str:strs -> - runST $ - do let !len = List.foldl' (\w s -> w + 1 + size s) (size str) strs - mba <- newByteArray len - joinHelp sep mba 0 str strs - freeze mba - - -joinHelp :: Word8 -> MBA s -> Int -> Utf8 t -> [Utf8 t] -> ST s () -joinHelp sep mba offset str strings = - let - !len = size str - in - case strings of - [] -> - copy str 0 mba offset len - - s:ss -> - do copy str 0 mba offset len - let !dotOffset = offset + len - writeWord8 mba dotOffset sep - let !newOffset = dotOffset + 1 - joinHelp sep mba newOffset s ss - - - --- EQUAL - - -instance Eq (Utf8 t) where - (==) (Utf8 ba1#) (Utf8 ba2#) = - let - !len1# = sizeofByteArray# ba1# - !len2# = sizeofByteArray# ba2# - in - isTrue# (len1# ==# len2#) - && - isTrue# (0# ==# compareByteArrays# ba1# 0# ba2# 0# len1#) - - - --- COMPARE - - -instance Ord (Utf8 t) where - compare (Utf8 ba1#) (Utf8 ba2#) = - let - !len1# = sizeofByteArray# ba1# - !len2# = sizeofByteArray# ba2# - !len# = if isTrue# (len1# <# len2#) then len1# else len2# - !cmp# = compareByteArrays# ba1# 0# ba2# 0# len# - in - case () of - _ | isTrue# (cmp# <# 0#) -> LT - | isTrue# (cmp# ># 0#) -> GT - | isTrue# (len1# <# len2#) -> LT - | isTrue# (len1# ># len2#) -> GT - | True -> EQ - - - --- FROM STRING - - -fromChars :: [Char] -> Utf8 t -fromChars chars = - runST - ( - do mba <- newByteArray (sum (map getWidth chars)) - writeChars mba 0 chars - ) - - -writeChars :: MBA s -> Int -> [Char] -> ST s (Utf8 t) -writeChars !mba !offset chars = - case chars of - [] -> - freeze mba - - char : chars - | n < 0x80 -> - do writeWord8 mba (offset ) (fromIntegral n) - writeChars mba (offset + 1) chars - - | n < 0x800 -> - do writeWord8 mba (offset ) (fromIntegral ((shiftR n 6 ) + 0xC0)) - writeWord8 mba (offset + 1) (fromIntegral (( n .&. 0x3F) + 0x80)) - writeChars mba (offset + 2) chars - - | n < 0x10000 -> - do writeWord8 mba (offset ) (fromIntegral ((shiftR n 12 ) + 0xE0)) - writeWord8 mba (offset + 1) (fromIntegral ((shiftR n 6 .&. 0x3F) + 0x80)) - writeWord8 mba (offset + 2) (fromIntegral (( n .&. 0x3F) + 0x80)) - writeChars mba (offset + 3) chars - - | otherwise -> - do writeWord8 mba (offset ) (fromIntegral ((shiftR n 18 ) + 0xF0)) - writeWord8 mba (offset + 1) (fromIntegral ((shiftR n 12 .&. 0x3F) + 0x80)) - writeWord8 mba (offset + 2) (fromIntegral ((shiftR n 6 .&. 0x3F) + 0x80)) - writeWord8 mba (offset + 3) (fromIntegral (( n .&. 0x3F) + 0x80)) - writeChars mba (offset + 4) chars - - where - n = Char.ord char - - -{-# INLINE getWidth #-} -getWidth :: Char -> Int -getWidth char - | code < 0x80 = 1 - | code < 0x800 = 2 - | code < 0x10000 = 3 - | otherwise = 4 - where - code = Char.ord char - - - --- TO CHARS - - -toChars :: Utf8 t -> [Char] -toChars (Utf8 ba#) = - toCharsHelp ba# 0# (sizeofByteArray# ba#) - - -toCharsHelp :: ByteArray# -> Int# -> Int# -> [Char] -toCharsHelp ba# offset# len# = - if isTrue# (offset# >=# len#) then - [] - else - let - !w# = indexWord8Array# ba# offset# - !(# char, width# #) - | isTrue# (ltWord# w# 0xC0##) = (# C# (chr# (word2Int# w#)), 1# #) - | isTrue# (ltWord# w# 0xE0##) = (# chr2 ba# offset# w#, 2# #) - | isTrue# (ltWord# w# 0xF0##) = (# chr3 ba# offset# w#, 3# #) - | True = (# chr4 ba# offset# w#, 4# #) - - !newOffset# = offset# +# width# - in - char : toCharsHelp ba# newOffset# len# - - -{-# INLINE chr2 #-} -chr2 :: ByteArray# -> Int# -> Word# -> Char -chr2 ba# offset# firstWord# = - let - !i1# = word2Int# firstWord# - !i2# = word2Int# (indexWord8Array# ba# (offset# +# 1#)) - !c1# = uncheckedIShiftL# (i1# -# 0xC0#) 6# - !c2# = i2# -# 0x80# - in - C# (chr# (c1# +# c2#)) - - -{-# INLINE chr3 #-} -chr3 :: ByteArray# -> Int# -> Word# -> Char -chr3 ba# offset# firstWord# = - let - !i1# = word2Int# firstWord# - !i2# = word2Int# (indexWord8Array# ba# (offset# +# 1#)) - !i3# = word2Int# (indexWord8Array# ba# (offset# +# 2#)) - !c1# = uncheckedIShiftL# (i1# -# 0xE0#) 12# - !c2# = uncheckedIShiftL# (i2# -# 0x80#) 6# - !c3# = i3# -# 0x80# - in - C# (chr# (c1# +# c2# +# c3#)) - - -{-# INLINE chr4 #-} -chr4 :: ByteArray# -> Int# -> Word# -> Char -chr4 ba# offset# firstWord# = - let - !i1# = word2Int# firstWord# - !i2# = word2Int# (indexWord8Array# ba# (offset# +# 1#)) - !i3# = word2Int# (indexWord8Array# ba# (offset# +# 2#)) - !i4# = word2Int# (indexWord8Array# ba# (offset# +# 3#)) - !c1# = uncheckedIShiftL# (i1# -# 0xF0#) 18# - !c2# = uncheckedIShiftL# (i2# -# 0x80#) 12# - !c3# = uncheckedIShiftL# (i3# -# 0x80#) 6# - !c4# = i4# -# 0x80# - in - C# (chr# (c1# +# c2# +# c3# +# c4#)) - - - --- TO BUILDER - - -{-# INLINE toBuilder #-} -toBuilder :: Utf8 t -> B.Builder -toBuilder = - \bytes -> B.builder (toBuilderHelp bytes) - - -{-# INLINE toBuilderHelp #-} -toBuilderHelp :: Utf8 t -> B.BuildStep a -> B.BuildStep a -toBuilderHelp !bytes@(Utf8 ba#) k = - go 0 (I# (sizeofByteArray# ba#)) - where - go !offset !end !(B.BufferRange bOffset bEnd) = - let - !bLen = minusPtr bEnd bOffset - !len = end - offset - in - if len <= bLen then - do copyToPtr bytes offset bOffset len - let !br' = B.BufferRange (plusPtr bOffset len) bEnd - k br' - else - do copyToPtr bytes offset bOffset bLen - let !offset' = offset + bLen - return $ B.bufferFull 1 bEnd (go offset' end) - - - --- TO ESCAPED BUILDER - - -{-# INLINE toEscapedBuilder #-} -toEscapedBuilder :: Word8 -> Word8 -> Utf8 t -> B.Builder -toEscapedBuilder before after = - \name -> B.builder (toEscapedBuilderHelp before after name) - - -{-# INLINE toEscapedBuilderHelp #-} -toEscapedBuilderHelp :: Word8 -> Word8 -> Utf8 t -> B.BuildStep a -> B.BuildStep a -toEscapedBuilderHelp before after !name@(Utf8 ba#) k = - go 0 (I# (sizeofByteArray# ba#)) - where - go !offset !len !(B.BufferRange bOffset bEnd) = - let - !bLen = minusPtr bEnd bOffset - in - if len <= bLen then - do -- PERF test if writing word-by-word is faster - copyToPtr name offset bOffset len - escape before after bOffset name offset len 0 - let !newBufferRange = B.BufferRange (plusPtr bOffset len) bEnd - k newBufferRange - else - do copyToPtr name offset bOffset bLen - escape before after bOffset name offset bLen 0 - let !newOffset = offset + bLen - let !newLength = len - bLen - return $ B.bufferFull 1 bEnd (go newOffset newLength) - - -escape :: Word8 -> Word8 -> Ptr a -> Utf8 t -> Int -> Int -> Int -> IO () -escape before@(W8# before#) after ptr name@(Utf8 ba#) offset@(I# offset#) len@(I# len#) i@(I# i#) = - if isTrue# (i# <# len#) then - if isTrue# (eqWord# before# (indexWord8Array# ba# (offset# +# i#))) - then - do writeWordToPtr ptr i after - escape before after ptr name offset len (i + 1) - else - do escape before after ptr name offset len (i + 1) - - else - return () - - - --- FROM PTR - - -fromPtr :: Ptr Word8 -> Ptr Word8 -> Utf8 t -fromPtr pos end = - unsafeDupablePerformIO (stToIO ( - do let !len = minusPtr end pos - mba <- newByteArray len - copyFromPtr pos mba 0 len - freeze mba - )) - - - --- FROM SNIPPET - - -fromSnippet :: P.Snippet -> Utf8 t -fromSnippet (P.Snippet fptr off len _ _) = - unsafeDupablePerformIO (stToIO ( - do mba <- newByteArray len - let !pos = plusPtr (unsafeForeignPtrToPtr fptr) off - copyFromPtr pos mba 0 len - freeze mba - )) - - - --- BINARY - - -putUnder256 :: Utf8 t -> Put -putUnder256 bytes = - do putWord8 (fromIntegral (size bytes)) - putBuilder (toBuilder bytes) - - -getUnder256 :: Get (Utf8 t) -getUnder256 = - do word <- getWord8 - let !n = fromIntegral word - readN n (copyFromByteString n) - - -putVeryLong :: Utf8 t -> Put -putVeryLong bytes = - do put (size bytes) - putBuilder (toBuilder bytes) - - -getVeryLong :: Get (Utf8 t) -getVeryLong = - do n <- get - if n > 0 - then readN n (copyFromByteString n) - else return empty - - - --- COPY FROM BYTESTRING - - -{-# INLINE copyFromByteString #-} -copyFromByteString :: Int -> B.ByteString -> Utf8 t -copyFromByteString len (B.PS fptr offset _) = - unsafeDupablePerformIO - ( - do mba <- stToIO (newByteArray len) - stToIO (copyFromPtr (unsafeForeignPtrToPtr fptr `plusPtr` offset) mba 0 len) - touchForeignPtr fptr - stToIO (freeze mba) - ) - - - --- PRIMITIVES - - -data MBA s = - MBA# (MutableByteArray# s) - - -newByteArray :: Int -> ST s (MBA s) -- PERF see if newPinnedByteArray for len > 256 is positive -newByteArray (I# len#) = - ST $ \s -> - case newByteArray# len# s of - (# s, mba# #) -> (# s, MBA# mba# #) - - -freeze :: MBA s -> ST s (Utf8 t) -freeze (MBA# mba#) = - ST $ \s -> - case unsafeFreezeByteArray# mba# s of - (# s, ba# #) -> (# s, Utf8 ba# #) - - -copy :: Utf8 t -> Int -> MBA s -> Int -> Int -> ST s () -copy (Utf8 ba#) (I# offset#) (MBA# mba#) (I# i#) (I# len#) = - ST $ \s -> - case copyByteArray# ba# offset# mba# i# len# s of - s -> (# s, () #) - - -copyFromPtr :: Ptr a -> MBA RealWorld -> Int -> Int -> ST RealWorld () -copyFromPtr (Ptr src#) (MBA# mba#) (I# offset#) (I# len#) = - ST $ \s -> - case copyAddrToByteArray# src# mba# offset# len# s of - s -> (# s, () #) - - -copyToPtr :: Utf8 t -> Int -> Ptr a -> Int -> IO () -copyToPtr (Utf8 ba#) (I# offset#) (Ptr mba#) (I# len#) = - IO $ \s -> - case copyByteArrayToAddr# ba# offset# mba# len# s of - s -> (# s, () #) - - -{-# INLINE writeWord8 #-} -writeWord8 :: MBA s -> Int -> Word8 -> ST s () -writeWord8 (MBA# mba#) (I# offset#) (W8# w#) = - ST $ \s -> - case writeWord8Array# mba# offset# w# s of - s -> (# s, () #) - - -{-# INLINE writeWordToPtr #-} -writeWordToPtr :: Ptr a -> Int -> Word8 -> IO () -writeWordToPtr (Ptr addr#) (I# offset#) (W8# word#) = - IO $ \s -> - case writeWord8OffAddr# addr# offset# word# s of - s -> (# s, () #) diff --git a/compiler/src/Elm/Compiler/Imports.hs b/compiler/src/Elm/Compiler/Imports.hs deleted file mode 100644 index 066c841150..0000000000 --- a/compiler/src/Elm/Compiler/Imports.hs +++ /dev/null @@ -1,62 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE OverloadedStrings #-} -module Elm.Compiler.Imports - ( defaults - ) - where - - -import qualified Data.Name as Name - -import qualified AST.Source as Src -import qualified Elm.ModuleName as ModuleName -import qualified Reporting.Annotation as A - - - --- DEFAULTS - - -defaults :: [Src.Import] -defaults = - [ import_ ModuleName.basics Nothing Src.Open - , import_ ModuleName.debug Nothing closed - , import_ ModuleName.list Nothing (operator "::") - , import_ ModuleName.maybe Nothing (typeOpen Name.maybe) - , import_ ModuleName.result Nothing (typeOpen Name.result) - , import_ ModuleName.string Nothing (typeClosed Name.string) - , import_ ModuleName.char Nothing (typeClosed Name.char) - , import_ ModuleName.tuple Nothing closed - , import_ ModuleName.platform Nothing (typeClosed Name.program) - , import_ ModuleName.cmd (Just Name.cmd) (typeClosed Name.cmd) - , import_ ModuleName.sub (Just Name.sub) (typeClosed Name.sub) - ] - - -import_ :: ModuleName.Canonical -> Maybe Name.Name -> Src.Exposing -> Src.Import -import_ (ModuleName.Canonical _ name) maybeAlias exposing = - Src.Import (A.At A.zero name) maybeAlias exposing - - - --- EXPOSING - - -closed :: Src.Exposing -closed = - Src.Explicit [] - - -typeOpen :: Name.Name -> Src.Exposing -typeOpen name = - Src.Explicit [ Src.Upper (A.At A.zero name) (Src.Public A.zero) ] - - -typeClosed :: Name.Name -> Src.Exposing -typeClosed name = - Src.Explicit [ Src.Upper (A.At A.zero name) Src.Private ] - - -operator :: Name.Name -> Src.Exposing -operator op = - Src.Explicit [ Src.Operator A.zero op ] diff --git a/compiler/src/Elm/Compiler/Type.hs b/compiler/src/Elm/Compiler/Type.hs deleted file mode 100644 index e5b6184689..0000000000 --- a/compiler/src/Elm/Compiler/Type.hs +++ /dev/null @@ -1,194 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE OverloadedStrings #-} -module Elm.Compiler.Type - ( Type(..) - , RT.Context(..) - , toDoc - , DebugMetadata(..) - , Alias(..) - , Union(..) - , encode - , decoder - , encodeMetadata - ) - where - - -import qualified Data.Name as Name - -import qualified AST.Source as Src -import qualified Json.Decode as D -import qualified Json.Encode as E -import Json.Encode ((==>)) -import qualified Json.String as Json -import qualified Parse.Primitives as P -import qualified Parse.Type as Type -import qualified Reporting.Annotation as A -import qualified Reporting.Doc as D -import qualified Reporting.Render.Type as RT -import qualified Reporting.Render.Type.Localizer as L - - - --- TYPES - - -data Type - = Lambda Type Type - | Var Name.Name - | Type Name.Name [Type] - | Record [(Name.Name, Type)] (Maybe Name.Name) - | Unit - | Tuple Type Type [Type] - - -data DebugMetadata = - DebugMetadata - { _message :: Type - , _aliases :: [Alias] - , _unions :: [Union] - } - - -data Alias = Alias Name.Name [Name.Name] Type -data Union = Union Name.Name [Name.Name] [(Name.Name, [Type])] - - - --- TO DOC - - -toDoc :: L.Localizer -> RT.Context -> Type -> D.Doc -toDoc localizer context tipe = - case tipe of - Lambda _ _ -> - let - a:b:cs = - map (toDoc localizer RT.Func) (collectLambdas tipe) - in - RT.lambda context a b cs - - Var name -> - D.fromName name - - Unit -> - "()" - - Tuple a b cs -> - RT.tuple - (toDoc localizer RT.None a) - (toDoc localizer RT.None b) - (map (toDoc localizer RT.None) cs) - - Type name args -> - RT.apply - context - (D.fromName name) - (map (toDoc localizer RT.App) args) - - Record fields ext -> - RT.record - (map (entryToDoc localizer) fields) - (fmap D.fromName ext) - - -entryToDoc :: L.Localizer -> (Name.Name, Type) -> (D.Doc, D.Doc) -entryToDoc localizer (field, fieldType) = - ( D.fromName field, toDoc localizer RT.None fieldType ) - - -collectLambdas :: Type -> [Type] -collectLambdas tipe = - case tipe of - Lambda arg body -> - arg : collectLambdas body - - _ -> - [tipe] - - - --- JSON for TYPE - - -encode :: Type -> E.Value -encode tipe = - E.chars $ D.toLine (toDoc L.empty RT.None tipe) - - -decoder :: D.Decoder () Type -decoder = - let - parser = - P.specialize (\_ _ _ -> ()) (fromRawType . fst <$> Type.expression) - in - D.customString parser (\_ _ -> ()) - - -fromRawType :: Src.Type -> Type -fromRawType (A.At _ astType) = - case astType of - Src.TLambda t1 t2 -> - Lambda (fromRawType t1) (fromRawType t2) - - Src.TVar x -> - Var x - - Src.TUnit -> - Unit - - Src.TTuple a b cs -> - Tuple - (fromRawType a) - (fromRawType b) - (map fromRawType cs) - - Src.TType _ name args -> - Type name (map fromRawType args) - - Src.TTypeQual _ _ name args -> - Type name (map fromRawType args) - - Src.TRecord fields ext -> - let fromField (A.At _ field, tipe) = (field, fromRawType tipe) in - Record - (map fromField fields) - (fmap A.toValue ext) - - - --- JSON for PROGRAM - - -encodeMetadata :: DebugMetadata -> E.Value -encodeMetadata (DebugMetadata msg aliases unions) = - E.object - [ "message" ==> encode msg - , "aliases" ==> E.object (map toTypeAliasField aliases) - , "unions" ==> E.object (map toCustomTypeField unions) - ] - - -toTypeAliasField :: Alias -> ( Json.String, E.Value ) -toTypeAliasField (Alias name args tipe) = - ( Json.fromName name - , E.object - [ "args" ==> E.list E.name args - , "type" ==> encode tipe - ] - ) - - -toCustomTypeField :: Union -> ( Json.String, E.Value ) -toCustomTypeField (Union name args constructors) = - ( Json.fromName name - , E.object - [ "args" ==> E.list E.name args - , "tags" ==> E.object (map toVariantObject constructors) - ] - ) - - -toVariantObject :: (Name.Name, [Type]) -> ( Json.String, E.Value ) -toVariantObject (name, args) = - ( Json.fromName name, E.list encode args ) diff --git a/compiler/src/Elm/Compiler/Type/Extract.hs b/compiler/src/Elm/Compiler/Type/Extract.hs deleted file mode 100644 index 719c64a865..0000000000 --- a/compiler/src/Elm/Compiler/Type/Extract.hs +++ /dev/null @@ -1,285 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE BangPatterns, OverloadedStrings, Rank2Types #-} -module Elm.Compiler.Type.Extract - ( fromAnnotation - , fromType - , Types(..) - , mergeMany - , merge - , fromInterface - , fromDependencyInterface - , fromMsg - ) - where - - -import Data.Map ((!)) -import qualified Data.Map as Map -import qualified Data.Maybe as Maybe -import qualified Data.Name as Name -import qualified Data.Set as Set - -import qualified AST.Canonical as Can -import qualified AST.Optimized as Opt -import qualified AST.Utils.Type as Type -import qualified Elm.Compiler.Type as T -import qualified Elm.Interface as I -import qualified Elm.ModuleName as ModuleName - - - --- EXTRACTION - - -fromAnnotation :: Can.Annotation -> T.Type -fromAnnotation (Can.Forall _ astType) = - fromType astType - - -fromType :: Can.Type -> T.Type -fromType astType = - snd (run (extract astType)) - - -extract :: Can.Type -> Extractor T.Type -extract astType = - case astType of - Can.TLambda arg result -> - T.Lambda - <$> extract arg - <*> extract result - - Can.TVar x -> - pure (T.Var x) - - Can.TType home name args -> - addUnion (Opt.Global home name) (T.Type (toPublicName home name)) - <*> traverse extract args - - Can.TRecord fields ext -> - do efields <- traverse (traverse extract) (Can.fieldsToList fields) - pure (T.Record efields ext) - - Can.TUnit -> - pure T.Unit - - Can.TTuple a b maybeC -> - T.Tuple - <$> extract a - <*> extract b - <*> traverse extract (Maybe.maybeToList maybeC) - - Can.TAlias home name args aliasType -> - do addAlias (Opt.Global home name) () - _ <- extract (Type.dealias args aliasType) - T.Type (toPublicName home name) - <$> traverse (extract . snd) args - - -toPublicName :: ModuleName.Canonical -> Name.Name -> Name.Name -toPublicName (ModuleName.Canonical _ home) name = - Name.sepBy 0x2E {- . -} home name - - - --- TRANSITIVELY AVAILABLE TYPES - - -newtype Types = - Types (Map.Map ModuleName.Canonical Types_) - -- PERF profile Opt.Global representation - -- current representation needs less allocation - -- but maybe the lookup is much worse - - -data Types_ = - Types_ - { _union_info :: Map.Map Name.Name Can.Union - , _alias_info :: Map.Map Name.Name Can.Alias - } - - -mergeMany :: [Types] -> Types -mergeMany listOfTypes = - case listOfTypes of - [] -> Types Map.empty - t:ts -> foldr merge t ts - - -merge :: Types -> Types -> Types -merge (Types types1) (Types types2) = - Types (Map.union types1 types2) - - -fromInterface :: ModuleName.Raw -> I.Interface -> Types -fromInterface name (I.Interface pkg _ unions aliases _) = - Types $ Map.singleton (ModuleName.Canonical pkg name) $ - Types_ (Map.map I.extractUnion unions) (Map.map I.extractAlias aliases) - - -fromDependencyInterface :: ModuleName.Canonical -> I.DependencyInterface -> Types -fromDependencyInterface home di = - Types $ Map.singleton home $ - case di of - I.Public (I.Interface _ _ unions aliases _) -> - Types_ (Map.map I.extractUnion unions) (Map.map I.extractAlias aliases) - - I.Private _ unions aliases -> - Types_ unions aliases - - - --- EXTRACT MODEL, MSG, AND ANY TRANSITIVE DEPENDENCIES - - -fromMsg :: Types -> Can.Type -> T.DebugMetadata -fromMsg types message = - let - (msgDeps, msgType) = - run (extract message) - - (aliases, unions) = - extractTransitive types noDeps msgDeps - in - T.DebugMetadata msgType aliases unions - - -extractTransitive :: Types -> Deps -> Deps -> ( [T.Alias], [T.Union] ) -extractTransitive types (Deps seenAliases seenUnions) (Deps nextAliases nextUnions) = - let - aliases = Set.difference nextAliases seenAliases - unions = Set.difference nextUnions seenUnions - in - if Set.null aliases && Set.null unions then - ( [], [] ) - - else - let - (newDeps, result) = - run $ - (,) - <$> traverse (extractAlias types) (Set.toList aliases) - <*> traverse (extractUnion types) (Set.toList unions) - - oldDeps = - Deps (Set.union seenAliases nextAliases) (Set.union seenUnions nextUnions) - - remainingResult = - extractTransitive types oldDeps newDeps - in - mappend result remainingResult - - -extractAlias :: Types -> Opt.Global -> Extractor T.Alias -extractAlias (Types dict) (Opt.Global home name) = - let - (Can.Alias args aliasType) = _alias_info (dict ! home) ! name - in - T.Alias (toPublicName home name) args <$> extract aliasType - - -extractUnion :: Types -> Opt.Global -> Extractor T.Union -extractUnion (Types dict) (Opt.Global home name) = - if name == Name.list && home == ModuleName.list - then return $ T.Union (toPublicName home name) ["a"] [] - else - let - pname = toPublicName home name - (Can.Union vars ctors _ _) = _union_info (dict ! home) ! name - in - T.Union pname vars <$> traverse extractCtor ctors - - -extractCtor :: Can.Ctor -> Extractor (Name.Name, [T.Type]) -extractCtor (Can.Ctor ctor _ _ args) = - (,) ctor <$> traverse extract args - - - --- DEPS - - -data Deps = - Deps - { _aliases :: Set.Set Opt.Global - , _unions :: Set.Set Opt.Global - } - - -{-# NOINLINE noDeps #-} -noDeps :: Deps -noDeps = - Deps Set.empty Set.empty - - - --- EXTRACTOR - - -newtype Extractor a = - Extractor ( - forall result. - Set.Set Opt.Global - -> Set.Set Opt.Global - -> (Set.Set Opt.Global -> Set.Set Opt.Global -> a -> result) - -> result - ) - - -run :: Extractor a -> (Deps, a) -run (Extractor k) = - k Set.empty Set.empty $ \aliases unions value -> - ( Deps aliases unions, value ) - - -addAlias :: Opt.Global -> a -> Extractor a -addAlias alias value = - Extractor $ \aliases unions ok -> - ok (Set.insert alias aliases) unions value - - -addUnion :: Opt.Global -> a -> Extractor a -addUnion union value = - Extractor $ \aliases unions ok -> - ok aliases (Set.insert union unions) value - - -instance Functor Extractor where - fmap func (Extractor k) = - Extractor $ \aliases unions ok -> - let - ok1 a1 u1 value = - ok a1 u1 (func value) - in - k aliases unions ok1 - - -instance Applicative Extractor where - pure value = - Extractor $ \aliases unions ok -> - ok aliases unions value - - (<*>) (Extractor kf) (Extractor kv) = - Extractor $ \aliases unions ok -> - let - ok1 a1 u1 func = - let - ok2 a2 u2 value = - ok a2 u2 (func value) - in - kv a1 u1 ok2 - in - kf aliases unions ok1 - - -instance Monad Extractor where - return = pure - - (>>=) (Extractor ka) callback = - Extractor $ \aliases unions ok -> - let - ok1 a1 u1 value = - case callback value of - Extractor kb -> kb a1 u1 ok - in - ka aliases unions ok1 diff --git a/compiler/src/Elm/Constraint.hs b/compiler/src/Elm/Constraint.hs deleted file mode 100644 index 9c4d3705ec..0000000000 --- a/compiler/src/Elm/Constraint.hs +++ /dev/null @@ -1,260 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE OverloadedStrings #-} -module Elm.Constraint - ( Constraint - , exactly - , anything - , toChars - , satisfies - , check - , intersect - , goodElm - , defaultElm - , untilNextMajor - , untilNextMinor - , expand - -- - , Error(..) - , decoder - , encode - ) - where - - -import Control.Monad (liftM4) -import Data.Binary (Binary, get, put, getWord8, putWord8) - -import qualified Elm.Version as V -import qualified Json.Decode as D -import qualified Json.Encode as E -import qualified Parse.Primitives as P -import Parse.Primitives (Row, Col) - - - --- CONSTRAINTS - - -data Constraint - = Range V.Version Op Op V.Version - deriving (Eq) - - -data Op - = Less - | LessOrEqual - deriving (Eq) - - - --- COMMON CONSTRAINTS - - -exactly :: V.Version -> Constraint -exactly version = - Range version LessOrEqual LessOrEqual version - - -anything :: Constraint -anything = - Range V.one LessOrEqual LessOrEqual V.max - - - --- TO CHARS - - -toChars :: Constraint -> [Char] -toChars constraint = - case constraint of - Range lower lowerOp upperOp upper -> - V.toChars lower ++ opToChars lowerOp ++ "v" ++ opToChars upperOp ++ V.toChars upper - - -opToChars :: Op -> [Char] -opToChars op = - case op of - Less -> " < " - LessOrEqual -> " <= " - - - --- IS SATISFIED - - -satisfies :: Constraint -> V.Version -> Bool -satisfies constraint version = - case constraint of - Range lower lowerOp upperOp upper -> - isLess lowerOp lower version - && - isLess upperOp version upper - - -isLess :: (Ord a) => Op -> (a -> a -> Bool) -isLess op = - case op of - Less -> - (<) - - LessOrEqual -> - (<=) - - -check :: Constraint -> V.Version -> Ordering -check constraint version = - case constraint of - Range lower lowerOp upperOp upper -> - if not (isLess lowerOp lower version) then - LT - - else if not (isLess upperOp version upper) then - GT - - else - EQ - - - --- INTERSECT - - -intersect :: Constraint -> Constraint -> Maybe Constraint -intersect (Range lo lop hop hi) (Range lo_ lop_ hop_ hi_) = - let - (newLo, newLop) = - case compare lo lo_ of - LT -> (lo_, lop_) - EQ -> (lo, if elem Less [lop,lop_] then Less else LessOrEqual) - GT -> (lo, lop) - - (newHi, newHop) = - case compare hi hi_ of - LT -> (hi, hop) - EQ -> (hi, if elem Less [hop, hop_] then Less else LessOrEqual) - GT -> (hi_, hop_) - in - if newLo <= newHi then - Just (Range newLo newLop newHop newHi) - else - Nothing - - - --- ELM CONSTRAINT - - -goodElm :: Constraint -> Bool -goodElm constraint = - satisfies constraint V.compiler - - -defaultElm :: Constraint -defaultElm = - if V._major V.compiler > 0 - then untilNextMajor V.compiler - else untilNextMinor V.compiler - - - --- CREATE CONSTRAINTS - - -untilNextMajor :: V.Version -> Constraint -untilNextMajor version = - Range version LessOrEqual Less (V.bumpMajor version) - - -untilNextMinor :: V.Version -> Constraint -untilNextMinor version = - Range version LessOrEqual Less (V.bumpMinor version) - - -expand :: Constraint -> V.Version -> Constraint -expand constraint@(Range lower lowerOp upperOp upper) version - | version < lower = - Range version LessOrEqual upperOp upper - - | version > upper = - Range lower lowerOp Less (V.bumpMajor version) - - | otherwise = - constraint - - - --- JSON - - -encode :: Constraint -> E.Value -encode constraint = - E.chars (toChars constraint) - - -decoder :: D.Decoder Error Constraint -decoder = - D.customString parser BadFormat - - - --- BINARY - - -instance Binary Constraint where - get = liftM4 Range get get get get - put (Range a b c d) = put a >> put b >> put c >> put d - - -instance Binary Op where - put op = - case op of - Less -> putWord8 0 - LessOrEqual -> putWord8 1 - - get = - do n <- getWord8 - case n of - 0 -> return Less - 1 -> return LessOrEqual - _ -> fail "binary encoding of Op was corrupted" - - - --- PARSER - - -data Error - = BadFormat Row Col - | InvalidRange V.Version V.Version - - -parser :: P.Parser Error Constraint -parser = - do lower <- parseVersion - P.word1 0x20 {- -} BadFormat - loOp <- parseOp - P.word1 0x20 {- -} BadFormat - P.word1 0x76 {-v-} BadFormat - P.word1 0x20 {- -} BadFormat - hiOp <- parseOp - P.word1 0x20 {- -} BadFormat - higher <- parseVersion - P.Parser $ \state@(P.State _ _ _ _ row col) _ eok _ eerr -> - if lower < higher - then eok (Range lower loOp hiOp higher) state - else eerr row col (\_ _ -> InvalidRange lower higher) - - -parseVersion :: P.Parser Error V.Version -parseVersion = - P.specialize (\(r,c) _ _ -> BadFormat r c) V.parser - - -parseOp :: P.Parser Error Op -parseOp = - do P.word1 0x3C {-<-} BadFormat - P.oneOfWithFallback - [ do P.word1 0x3D {-=-} BadFormat - return LessOrEqual - ] - Less diff --git a/compiler/src/Elm/Docs.hs b/compiler/src/Elm/Docs.hs deleted file mode 100644 index d3a0434cef..0000000000 --- a/compiler/src/Elm/Docs.hs +++ /dev/null @@ -1,587 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE BangPatterns, MultiWayIf, OverloadedStrings, UnboxedTuples #-} -module Elm.Docs - ( Documentation - , Module(..) - , fromModule - , Union(..) - , Alias(..) - , Value(..) - , Binop(..) - , Binop.Associativity(..) - , Binop.Precedence(..) - , Error(..) - , decoder - , encode - ) - where - - -import qualified Data.Coerce as Coerce -import qualified Data.List as List -import Data.Map ((!)) -import qualified Data.Map as Map -import qualified Data.Map.Merge.Strict as Map -import qualified Data.Name as Name -import qualified Data.NonEmptyList as NE -import qualified Data.OneOrMore as OneOrMore -import Data.Word (Word8) -import Foreign.Ptr (Ptr, plusPtr) - -import qualified AST.Canonical as Can -import qualified AST.Source as Src -import qualified AST.Utils.Binop as Binop -import qualified Elm.Compiler.Type as Type -import qualified Elm.Compiler.Type.Extract as Extract -import qualified Elm.ModuleName as ModuleName -import qualified Json.Decode as D -import qualified Json.Encode as E -import Json.Encode ((==>)) -import qualified Json.String as Json -import Parse.Primitives (Row, Col, word1) -import qualified Parse.Primitives as P -import qualified Parse.Space as Space -import qualified Parse.Symbol as Symbol -import qualified Parse.Variable as Var -import qualified Reporting.Annotation as A -import qualified Reporting.Error.Docs as E -import qualified Reporting.Result as Result - - - --- DOCUMENTATION - - -type Documentation = - Map.Map Name.Name Module - - -data Module = - Module - { _name :: Name.Name - , _comment :: Comment - , _unions :: Map.Map Name.Name Union - , _aliases :: Map.Map Name.Name Alias - , _values :: Map.Map Name.Name Value - , _binops :: Map.Map Name.Name Binop - } - -type Comment = Json.String - -data Alias = Alias Comment [Name.Name] Type.Type -data Union = Union Comment [Name.Name] [(Name.Name, [Type.Type])] -data Value = Value Comment Type.Type -data Binop = Binop Comment Type.Type Binop.Associativity Binop.Precedence - - - --- JSON - - -encode :: Documentation -> E.Value -encode docs = - E.list encodeModule (Map.elems docs) - - -encodeModule :: Module -> E.Value -encodeModule (Module name comment unions aliases values binops) = - E.object $ - [ "name" ==> ModuleName.encode name - , "comment" ==> E.string comment - , "unions" ==> E.list encodeUnion (Map.toList unions) - , "aliases" ==> E.list encodeAlias (Map.toList aliases) - , "values" ==> E.list encodeValue (Map.toList values) - , "binops" ==> E.list encodeBinop (Map.toList binops) - ] - - -data Error - = BadAssociativity - | BadModuleName - | BadType - - -decoder :: D.Decoder Error Documentation -decoder = - toDict <$> D.list moduleDecoder - - -toDict :: [Module] -> Documentation -toDict modules = - Map.fromList (map toDictHelp modules) - - -toDictHelp :: Module -> (Name.Name, Module) -toDictHelp modul@(Module name _ _ _ _ _) = - (name, modul) - - -moduleDecoder :: D.Decoder Error Module -moduleDecoder = - Module - <$> D.field "name" moduleNameDecoder - <*> D.field "comment" D.string - <*> D.field "unions" (dictDecoder union) - <*> D.field "aliases" (dictDecoder alias) - <*> D.field "values" (dictDecoder value) - <*> D.field "binops" (dictDecoder binop) - - -dictDecoder :: D.Decoder Error a -> D.Decoder Error (Map.Map Name.Name a) -dictDecoder entryDecoder = - Map.fromList <$> D.list (named entryDecoder) - - -named :: D.Decoder Error a -> D.Decoder Error (Name.Name, a) -named entryDecoder = - (,) - <$> D.field "name" nameDecoder - <*> entryDecoder - - -nameDecoder :: D.Decoder e Name.Name -nameDecoder = - fmap Coerce.coerce D.string - - -moduleNameDecoder :: D.Decoder Error ModuleName.Raw -moduleNameDecoder = - D.mapError (const BadModuleName) ModuleName.decoder - - -typeDecoder :: D.Decoder Error Type.Type -typeDecoder = - D.mapError (const BadType) Type.decoder - - - --- UNION JSON - - -encodeUnion :: (Name.Name, Union) -> E.Value -encodeUnion (name, Union comment args cases) = - E.object - [ "name" ==> E.name name - , "comment" ==> E.string comment - , "args" ==> E.list E.name args - , "cases" ==> E.list encodeCase cases - ] - - -union :: D.Decoder Error Union -union = - Union - <$> D.field "comment" D.string - <*> D.field "args" (D.list nameDecoder) - <*> D.field "cases" (D.list caseDecoder) - - -encodeCase :: ( Name.Name, [Type.Type] ) -> E.Value -encodeCase ( tag, args ) = - E.list id [ E.name tag, E.list Type.encode args ] - - -caseDecoder :: D.Decoder Error ( Name.Name, [Type.Type] ) -caseDecoder = - D.pair nameDecoder (D.list typeDecoder) - - - --- ALIAS JSON - - -encodeAlias :: (Name.Name, Alias) -> E.Value -encodeAlias ( name, Alias comment args tipe) = - E.object - [ "name" ==> E.name name - , "comment" ==> E.string comment - , "args" ==> E.list E.name args - , "type" ==> Type.encode tipe - ] - - -alias :: D.Decoder Error Alias -alias = - Alias - <$> D.field "comment" D.string - <*> D.field "args" (D.list nameDecoder) - <*> D.field "type" typeDecoder - - - --- VALUE JSON - - -encodeValue :: (Name.Name, Value) -> E.Value -encodeValue (name, Value comment tipe) = - E.object - [ "name" ==> E.name name - , "comment" ==> E.string comment - , "type" ==> Type.encode tipe - ] - - -value :: D.Decoder Error Value -value = - Value - <$> D.field "comment" D.string - <*> D.field "type" typeDecoder - - - --- BINOP JSON - - -encodeBinop :: (Name.Name, Binop) -> E.Value -encodeBinop (name, Binop comment tipe assoc prec) = - E.object - [ "name" ==> E.name name - , "comment" ==> E.string comment - , "type" ==> Type.encode tipe - , "associativity" ==> encodeAssoc assoc - , "precedence" ==> encodePrec prec - ] - - -binop :: D.Decoder Error Binop -binop = - Binop - <$> D.field "comment" D.string - <*> D.field "type" typeDecoder - <*> D.field "associativity" assocDecoder - <*> D.field "precedence" precDecoder - - - --- ASSOCIATIVITY JSON - - -encodeAssoc :: Binop.Associativity -> E.Value -encodeAssoc assoc = - case assoc of - Binop.Left -> E.chars "left" - Binop.Non -> E.chars "non" - Binop.Right -> E.chars "right" - - -assocDecoder :: D.Decoder Error Binop.Associativity -assocDecoder = - let - left = Json.fromChars "left" - non = Json.fromChars "non" - right = Json.fromChars "right" - in - do str <- D.string - if | str == left -> return Binop.Left - | str == non -> return Binop.Non - | str == right -> return Binop.Right - | otherwise -> D.failure BadAssociativity - - - --- PRECEDENCE JSON - - -encodePrec :: Binop.Precedence -> E.Value -encodePrec (Binop.Precedence n) = - E.int n - - -precDecoder :: D.Decoder Error Binop.Precedence -precDecoder = - Binop.Precedence <$> D.int - - - --- FROM MODULE - - -fromModule :: Can.Module -> Either E.Error Module -fromModule modul@(Can.Module _ exports docs _ _ _ _ _) = - case exports of - Can.ExportEverything region -> - Left (E.ImplicitExposing region) - - Can.Export exportDict -> - case docs of - Src.NoDocs region -> - Left (E.NoDocs region) - - Src.YesDocs overview comments -> - do names <- parseOverview overview - checkNames exportDict names - checkDefs exportDict overview (Map.fromList comments) modul - - - --- PARSE OVERVIEW - - -parseOverview :: Src.Comment -> Either E.Error [A.Located Name.Name] -parseOverview (Src.Comment snippet) = - case P.fromSnippet (chompOverview []) E.BadEnd snippet of - Left err -> - Left (E.SyntaxProblem err) - - Right names -> - Right names - - -type Parser a = - P.Parser E.SyntaxProblem a - - -chompOverview :: [A.Located Name.Name] -> Parser [A.Located Name.Name] -chompOverview names = - do isDocs <- chompUntilDocs - if isDocs - then - do Space.chomp E.Space - chompOverview =<< chompDocs names - else - return names - - -chompDocs :: [A.Located Name.Name] -> Parser [A.Located Name.Name] -chompDocs names = - do name <- - P.addLocation $ - P.oneOf E.Name - [ Var.lower E.Name - , Var.upper E.Name - , chompOperator - ] - - Space.chomp E.Space - - P.oneOfWithFallback - [ do pos <- P.getPosition - Space.checkIndent pos E.Comma - word1 0x2C {-,-} E.Comma - Space.chomp E.Space - chompDocs (name:names) - ] - (name:names) - - -chompOperator :: Parser Name.Name -chompOperator = - do word1 0x28 {-(-} E.Op - op <- Symbol.operator E.Op E.OpBad - word1 0x29 {-)-} E.Op - return op - - --- TODO add rule that @docs must be after newline in 0.20 --- -chompUntilDocs :: Parser Bool -chompUntilDocs = - P.Parser $ \(P.State src pos end indent row col) cok _ _ _ -> - let - (# isDocs, newPos, newRow, newCol #) = untilDocs pos end row col - !newState = P.State src newPos end indent newRow newCol - in - cok isDocs newState - - -untilDocs :: Ptr Word8 -> Ptr Word8 -> Row -> Col -> (# Bool, Ptr Word8, Row, Col #) -untilDocs pos end row col = - if pos >= end then - (# False, pos, row, col #) - else - let !word = P.unsafeIndex pos in - if word == 0x0A {-\n-} then - untilDocs (plusPtr pos 1) end (row + 1) 1 - else - let !pos5 = plusPtr pos 5 in - if pos5 <= end - && P.unsafeIndex ( pos ) == 0x40 {-@-} - && P.unsafeIndex (plusPtr pos 1) == 0x64 {-d-} - && P.unsafeIndex (plusPtr pos 2) == 0x6F {-o-} - && P.unsafeIndex (plusPtr pos 3) == 0x63 {-c-} - && P.unsafeIndex (plusPtr pos 4) == 0x73 {-s-} - && Var.getInnerWidth pos5 end == 0 - then - (# True, pos5, row, col + 5 #) - else - let !newPos = plusPtr pos (P.getCharWidth word) in - untilDocs newPos end row (col + 1) - - - --- CHECK NAMES - - -checkNames :: Map.Map Name.Name (A.Located Can.Export) -> [A.Located Name.Name] -> Either E.Error () -checkNames exports names = - let - docs = List.foldl' addName Map.empty names - loneDoc = Map.traverseMissing onlyInDocs - loneExport = Map.traverseMissing onlyInExports - checkBoth = Map.zipWithAMatched (\n _ r -> isUnique n r) - in - case Result.run (Map.mergeA loneExport loneDoc checkBoth exports docs) of - (_, Right _) -> Right () - (_, Left es) -> Left (E.NameProblems (OneOrMore.destruct NE.List es)) - - -type DocNameRegions = - Map.Map Name.Name (OneOrMore.OneOrMore A.Region) - - -addName :: DocNameRegions -> A.Located Name.Name -> DocNameRegions -addName dict (A.At region name) = - Map.insertWith OneOrMore.more name (OneOrMore.one region) dict - - -isUnique :: Name.Name -> OneOrMore.OneOrMore A.Region -> Result.Result i w E.NameProblem A.Region -isUnique name regions = - case regions of - OneOrMore.One region -> - Result.ok region - - OneOrMore.More left right -> - let (r1, r2) = OneOrMore.getFirstTwo left right in - Result.throw (E.NameDuplicate name r1 r2) - - -onlyInDocs :: Name.Name -> OneOrMore.OneOrMore A.Region -> Result.Result i w E.NameProblem a -onlyInDocs name regions = - do region <- isUnique name regions - Result.throw $ E.NameOnlyInDocs name region - - -onlyInExports :: Name.Name -> A.Located Can.Export -> Result.Result i w E.NameProblem a -onlyInExports name (A.At region _) = - Result.throw $ E.NameOnlyInExports name region - - - --- CHECK DEFS - - -checkDefs :: Map.Map Name.Name (A.Located Can.Export) -> Src.Comment -> Map.Map Name.Name Src.Comment -> Can.Module -> Either E.Error Module -checkDefs exportDict overview comments (Can.Module name _ _ decls unions aliases infixes effects) = - let - types = gatherTypes decls Map.empty - info = Info comments types unions aliases infixes effects - in - case Result.run (Map.traverseWithKey (checkExport info) exportDict) of - (_, Left problems ) -> Left $ E.DefProblems (OneOrMore.destruct NE.List problems) - (_, Right inserters) -> Right $ foldr ($) (emptyModule name overview) inserters - - -emptyModule :: ModuleName.Canonical -> Src.Comment -> Module -emptyModule (ModuleName.Canonical _ name) (Src.Comment overview) = - Module name (Json.fromComment overview) Map.empty Map.empty Map.empty Map.empty - - -data Info = - Info - { _iComments :: Map.Map Name.Name Src.Comment - , _iValues :: Map.Map Name.Name (Either A.Region Can.Type) - , _iUnions :: Map.Map Name.Name Can.Union - , _iAliases :: Map.Map Name.Name Can.Alias - , _iBinops :: Map.Map Name.Name Can.Binop - , _iEffects :: Can.Effects - } - - -checkExport :: Info -> Name.Name -> A.Located Can.Export -> Result.Result i w E.DefProblem (Module -> Module) -checkExport info name (A.At region export) = - case export of - Can.ExportValue -> - do tipe <- getType name info - comment <- getComment region name info - Result.ok $ \m -> - m { _values = Map.insert name (Value comment tipe) (_values m) } - - Can.ExportBinop -> - do let (Can.Binop_ assoc prec realName) = _iBinops info ! name - tipe <- getType realName info - comment <- getComment region realName info - Result.ok $ \m -> - m { _binops = Map.insert name (Binop comment tipe assoc prec) (_binops m) } - - Can.ExportAlias -> - do let (Can.Alias tvars tipe) = _iAliases info ! name - comment <- getComment region name info - Result.ok $ \m -> - m { _aliases = Map.insert name (Alias comment tvars (Extract.fromType tipe)) (_aliases m) } - - Can.ExportUnionOpen -> - do let (Can.Union tvars ctors _ _) = _iUnions info ! name - comment <- getComment region name info - Result.ok $ \m -> - m { _unions = Map.insert name (Union comment tvars (map dector ctors)) (_unions m) } - - Can.ExportUnionClosed -> - do let (Can.Union tvars _ _ _) = _iUnions info ! name - comment <- getComment region name info - Result.ok $ \m -> - m { _unions = Map.insert name (Union comment tvars []) (_unions m) } - - Can.ExportPort -> - do tipe <- getType name info - comment <- getComment region name info - Result.ok $ \m -> - m { _values = Map.insert name (Value comment tipe) (_values m) } - - -getComment :: A.Region -> Name.Name -> Info -> Result.Result i w E.DefProblem Comment -getComment region name info = - case Map.lookup name (_iComments info) of - Nothing -> - Result.throw (E.NoComment name region) - - Just (Src.Comment snippet) -> - Result.ok (Json.fromComment snippet) - - -getType :: Name.Name -> Info -> Result.Result i w E.DefProblem Type.Type -getType name info = - case _iValues info ! name of - Left region -> - Result.throw (E.NoAnnotation name region) - - Right tipe -> - Result.ok (Extract.fromType tipe) - - -dector :: Can.Ctor -> (Name.Name, [Type.Type]) -dector (Can.Ctor name _ _ args) = - ( name, map Extract.fromType args ) - - - --- GATHER TYPES - - -type Types = - Map.Map Name.Name (Either A.Region Can.Type) - - -gatherTypes :: Can.Decls -> Types -> Types -gatherTypes decls types = - case decls of - Can.Declare def subDecls -> - gatherTypes subDecls (addDef types def) - - Can.DeclareRec def defs subDecls -> - gatherTypes subDecls (List.foldl' addDef (addDef types def) defs) - - Can.SaveTheEnvironment -> - types - - -addDef :: Types -> Can.Def -> Types -addDef types def = - case def of - Can.Def (A.At region name) _ _ -> - Map.insert name (Left region) types - - Can.TypedDef (A.At _ name) _ typedArgs _ resultType -> - let - tipe = foldr Can.TLambda resultType (map snd typedArgs) - in - Map.insert name (Right tipe) types diff --git a/compiler/src/Elm/Float.hs b/compiler/src/Elm/Float.hs deleted file mode 100644 index 48c950fc4d..0000000000 --- a/compiler/src/Elm/Float.hs +++ /dev/null @@ -1,51 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE EmptyDataDecls, FlexibleInstances #-} -module Elm.Float - ( Float - , fromPtr - , toBuilder - ) - where - - -import Prelude hiding (Float) -import Data.Binary (Binary, get, put) -import qualified Data.ByteString.Builder as B -import qualified Data.Utf8 as Utf8 -import Data.Word (Word8) -import Foreign.Ptr (Ptr) - - - --- FLOATS - - -type Float = - Utf8.Utf8 ELM_FLOAT - - -data ELM_FLOAT - - - --- HELPERS - - -fromPtr :: Ptr Word8 -> Ptr Word8 -> Float -fromPtr = - Utf8.fromPtr - - -{-# INLINE toBuilder #-} -toBuilder :: Float -> B.Builder -toBuilder = - Utf8.toBuilder - - - --- BINARY - - -instance Binary (Utf8.Utf8 ELM_FLOAT) where - get = Utf8.getUnder256 - put = Utf8.putUnder256 diff --git a/compiler/src/Elm/Interface.hs b/compiler/src/Elm/Interface.hs deleted file mode 100644 index b34850be68..0000000000 --- a/compiler/src/Elm/Interface.hs +++ /dev/null @@ -1,254 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -module Elm.Interface - ( Interface(..) - , Union(..) - , Alias(..) - , Binop(..) - , fromModule - , toPublicUnion - , toPublicAlias - , DependencyInterface(..) - , public - , private - , privatize - , extractUnion - , extractAlias - ) - where - - -import Control.Monad (liftM, liftM3, liftM4, liftM5) -import Data.Binary -import Data.Map.Strict ((!)) -import qualified Data.Map.Strict as Map -import qualified Data.Map.Merge.Strict as Map -import qualified Data.Name as Name - -import qualified AST.Canonical as Can -import qualified AST.Utils.Binop as Binop -import qualified Elm.Package as Pkg -import qualified Reporting.Annotation as A - - - --- INTERFACE - - -data Interface = - Interface - { _home :: Pkg.Name - , _values :: Map.Map Name.Name Can.Annotation - , _unions :: Map.Map Name.Name Union - , _aliases :: Map.Map Name.Name Alias - , _binops :: Map.Map Name.Name Binop - } - deriving (Eq) - - -data Union - = OpenUnion Can.Union - | ClosedUnion Can.Union - | PrivateUnion Can.Union - deriving (Eq) - - -data Alias - = PublicAlias Can.Alias - | PrivateAlias Can.Alias - deriving (Eq) - - -data Binop = - Binop - { _op_name :: Name.Name - , _op_annotation :: Can.Annotation - , _op_associativity :: Binop.Associativity - , _op_precedence :: Binop.Precedence - } - deriving (Eq) - - - --- FROM MODULE - - -fromModule :: Pkg.Name -> Can.Module -> Map.Map Name.Name Can.Annotation -> Interface -fromModule home (Can.Module _ exports _ _ unions aliases binops _) annotations = - Interface - { _home = home - , _values = restrict exports annotations - , _unions = restrictUnions exports unions - , _aliases = restrictAliases exports aliases - , _binops = restrict exports (Map.map (toOp annotations) binops) - } - - -restrict :: Can.Exports -> Map.Map Name.Name a -> Map.Map Name.Name a -restrict exports dict = - case exports of - Can.ExportEverything _ -> - dict - - Can.Export explicitExports -> - Map.intersection dict explicitExports - - -toOp :: Map.Map Name.Name Can.Annotation -> Can.Binop -> Binop -toOp types (Can.Binop_ associativity precedence name) = - Binop name (types ! name) associativity precedence - - -restrictUnions :: Can.Exports -> Map.Map Name.Name Can.Union -> Map.Map Name.Name Union -restrictUnions exports unions = - case exports of - Can.ExportEverything _ -> - Map.map OpenUnion unions - - Can.Export explicitExports -> - Map.merge onLeft onRight onBoth explicitExports unions - where - onLeft = Map.dropMissing - onRight = Map.mapMissing (\_ union -> PrivateUnion union) - onBoth = Map.zipWithMatched $ \_ (A.At _ export) union -> - case export of - Can.ExportUnionOpen -> OpenUnion union - Can.ExportUnionClosed -> ClosedUnion union - _ -> error "impossible exports discovered in restrictUnions" - - -restrictAliases :: Can.Exports -> Map.Map Name.Name Can.Alias -> Map.Map Name.Name Alias -restrictAliases exports aliases = - case exports of - Can.ExportEverything _ -> - Map.map PublicAlias aliases - - Can.Export explicitExports -> - Map.merge onLeft onRight onBoth explicitExports aliases - where - onLeft = Map.dropMissing - onRight = Map.mapMissing (\_ a -> PrivateAlias a) - onBoth = Map.zipWithMatched (\_ _ a -> PublicAlias a) - - - --- TO PUBLIC - - -toPublicUnion :: Union -> Maybe Can.Union -toPublicUnion iUnion = - case iUnion of - OpenUnion union -> Just union - ClosedUnion (Can.Union vars _ _ opts) -> Just (Can.Union vars [] 0 opts) - PrivateUnion _ -> Nothing - - -toPublicAlias :: Alias -> Maybe Can.Alias -toPublicAlias iAlias = - case iAlias of - PublicAlias alias -> Just alias - PrivateAlias _ -> Nothing - - - --- DEPENDENCY INTERFACE - - -data DependencyInterface - = Public Interface - | Private - Pkg.Name - (Map.Map Name.Name Can.Union) - (Map.Map Name.Name Can.Alias) - - -public :: Interface -> DependencyInterface -public = - Public - - -private :: Interface -> DependencyInterface -private (Interface pkg _ unions aliases _) = - Private pkg (Map.map extractUnion unions) (Map.map extractAlias aliases) - - -extractUnion :: Union -> Can.Union -extractUnion iUnion = - case iUnion of - OpenUnion union -> union - ClosedUnion union -> union - PrivateUnion union -> union - - -extractAlias :: Alias -> Can.Alias -extractAlias iAlias = - case iAlias of - PublicAlias alias -> alias - PrivateAlias alias -> alias - - -privatize :: DependencyInterface -> DependencyInterface -privatize di = - case di of - Public i -> private i - Private _ _ _ -> di - - - --- BINARY - - -instance Binary Interface where - get = liftM5 Interface get get get get get - put (Interface a b c d e) = put a >> put b >> put c >> put d >> put e - - -instance Binary Union where - put union = - case union of - OpenUnion u -> putWord8 0 >> put u - ClosedUnion u -> putWord8 1 >> put u - PrivateUnion u -> putWord8 2 >> put u - - get = - do n <- getWord8 - case n of - 0 -> liftM OpenUnion get - 1 -> liftM ClosedUnion get - 2 -> liftM PrivateUnion get - _ -> fail "binary encoding of Union was corrupted" - - -instance Binary Alias where - put union = - case union of - PublicAlias a -> putWord8 0 >> put a - PrivateAlias a -> putWord8 1 >> put a - - get = - do n <- getWord8 - case n of - 0 -> liftM PublicAlias get - 1 -> liftM PrivateAlias get - _ -> fail "binary encoding of Alias was corrupted" - - -instance Binary Binop where - get = - liftM4 Binop get get get get - - put (Binop a b c d) = - put a >> put b >> put c >> put d - - -instance Binary DependencyInterface where - put union = - case union of - Public a -> putWord8 0 >> put a - Private a b c -> putWord8 1 >> put a >> put b >> put c - - get = - do n <- getWord8 - case n of - 0 -> liftM Public get - 1 -> liftM3 Private get get get - _ -> fail "binary encoding of DependencyInterface was corrupted" diff --git a/compiler/src/Elm/Kernel.hs b/compiler/src/Elm/Kernel.hs deleted file mode 100644 index e52c5a9b95..0000000000 --- a/compiler/src/Elm/Kernel.hs +++ /dev/null @@ -1,365 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE BangPatterns, EmptyDataDecls, OverloadedStrings, UnboxedTuples #-} -module Elm.Kernel - ( Content(..) - , Chunk(..) - , fromByteString - , countFields - ) - where - - -import Control.Monad (liftM, liftM2) -import Data.Binary (Binary, get, put, getWord8, putWord8) -import qualified Data.ByteString.Internal as B -import qualified Data.List as List -import qualified Data.Map as Map -import qualified Data.Name as Name -import Data.Word (Word8) -import Foreign.Ptr (Ptr, plusPtr, minusPtr) -import Foreign.ForeignPtr (ForeignPtr) -import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr) - -import qualified AST.Source as Src -import qualified Elm.ModuleName as ModuleName -import qualified Elm.Package as Pkg -import qualified Parse.Module as Module -import qualified Parse.Space as Space -import qualified Parse.Variable as Var -import Parse.Primitives hiding (fromByteString) -import qualified Parse.Primitives as P -import qualified Reporting.Annotation as A - - - --- CHUNK - - -data Chunk - = JS B.ByteString - | ElmVar ModuleName.Canonical Name.Name - | JsVar Name.Name Name.Name - | ElmField Name.Name - | JsField Int - | JsEnum Int - | Debug - | Prod - - - --- COUNT FIELDS - - -countFields :: [Chunk] -> Map.Map Name.Name Int -countFields chunks = - foldr addField Map.empty chunks - - -addField :: Chunk -> Map.Map Name.Name Int -> Map.Map Name.Name Int -addField chunk fields = - case chunk of - JS _ -> fields - ElmVar _ _ -> fields - JsVar _ _ -> fields - ElmField f -> Map.insertWith (+) f 1 fields - JsField _ -> fields - JsEnum _ -> fields - Debug -> fields - Prod -> fields - - - --- FROM FILE - - -data Content = - Content [Src.Import] [Chunk] - - -type Foreigns = - Map.Map ModuleName.Raw Pkg.Name - - -fromByteString :: Pkg.Name -> Foreigns -> B.ByteString -> Maybe Content -fromByteString pkg foreigns bytes = - case P.fromByteString (parser pkg foreigns) toError bytes of - Right content -> - Just content - - Left () -> - Nothing - - -parser :: Pkg.Name -> Foreigns -> Parser () Content -parser pkg foreigns = - do word2 0x2F 0x2A {-/*-} toError - Space.chomp ignoreError - Space.checkFreshLine toError - imports <- specialize ignoreError (Module.chompImports []) - word2 0x2A 0x2F {-*/-} toError - chunks <- parseChunks (toVarTable pkg foreigns imports) Map.empty Map.empty - return (Content imports chunks) - - -toError :: Row -> Col -> () -toError _ _ = - () - - -ignoreError :: a -> Row -> Col -> () -ignoreError _ _ _ = - () - - - --- PARSE CHUNKS - - -parseChunks :: VarTable -> Enums -> Fields -> Parser () [Chunk] -parseChunks vtable enums fields = - P.Parser $ \(P.State src pos end indent row col) cok _ cerr _ -> - let - (# chunks, newPos, newRow, newCol #) = - chompChunks vtable enums fields src pos end row col pos [] - in - if newPos == end then - cok chunks (P.State src newPos end indent newRow newCol) - else - cerr row col toError - - -chompChunks :: VarTable -> Enums -> Fields -> ForeignPtr Word8 -> Ptr Word8 -> Ptr Word8 -> Row -> Col -> Ptr Word8 -> [Chunk] -> (# [Chunk], Ptr Word8, Row, Col #) -chompChunks vs es fs src pos end row col lastPos revChunks = - if pos >= end then - let !js = toByteString src lastPos end in - (# reverse (JS js : revChunks), pos, row, col #) - - else - let !word = unsafeIndex pos in - if word == 0x5F {-_-} then - let - !pos1 = plusPtr pos 1 - !pos3 = plusPtr pos 3 - in - if pos3 <= end && unsafeIndex pos1 == 0x5F {-_-} then - let !js = toByteString src lastPos pos in - chompTag vs es fs src pos3 end row (col + 3) (JS js : revChunks) - else - chompChunks vs es fs src pos1 end row (col + 1) lastPos revChunks - - else if word == 0x0A {-\n-} then - chompChunks vs es fs src (plusPtr pos 1) end (row + 1) 1 lastPos revChunks - - else - let - !newPos = plusPtr pos (getCharWidth word) - in - chompChunks vs es fs src newPos end row (col + 1) lastPos revChunks - - -toByteString :: ForeignPtr Word8 -> Ptr Word8 -> Ptr Word8 -> B.ByteString -toByteString src pos end = - let - !off = minusPtr pos (unsafeForeignPtrToPtr src) - !len = minusPtr end pos - in - B.PS src off len - - - --- relies on external checks in chompChunks -chompTag :: VarTable -> Enums -> Fields -> ForeignPtr Word8 -> Ptr Word8 -> Ptr Word8 -> Row -> Col -> [Chunk] -> (# [Chunk], Ptr Word8, Row, Col #) -chompTag vs es fs src pos end row col revChunks = - let - (# newPos, newCol #) = Var.chompInnerChars pos end col - !tagPos = plusPtr pos (-1) - !word = unsafeIndex tagPos - in - if word == 0x24 {-$-} then - let - !name = Name.fromPtr pos newPos - in - chompChunks vs es fs src newPos end row newCol newPos $ - ElmField name : revChunks - else - let - !name = Name.fromPtr tagPos newPos - in - if 0x30 {-0-} <= word && word <= 0x39 {-9-} then - let - (enum, newEnums) = - lookupEnum (word - 0x30) name es - in - chompChunks vs newEnums fs src newPos end row newCol newPos $ - JsEnum enum : revChunks - - else if 0x61 {-a-} <= word && word <= 0x7A {-z-} then - let - (field, newFields) = - lookupField name fs - in - chompChunks vs es newFields src newPos end row newCol newPos $ - JsField field : revChunks - - else if name == "DEBUG" then - chompChunks vs es fs src newPos end row newCol newPos (Debug : revChunks) - - else if name == "PROD" then - chompChunks vs es fs src newPos end row newCol newPos (Prod : revChunks) - - else - case Map.lookup name vs of - Just chunk -> - chompChunks vs es fs src newPos end row newCol newPos (chunk : revChunks) - - Nothing -> - (# revChunks, pos, row, col #) - - - --- FIELDS - - -type Fields = - Map.Map Name.Name Int - - -lookupField :: Name.Name -> Fields -> (Int, Fields) -lookupField name fields = - case Map.lookup name fields of - Just n -> - ( n, fields ) - - Nothing -> - let n = Map.size fields in - ( n, Map.insert name n fields ) - - - --- ENUMS - - -type Enums = - Map.Map Word8 (Map.Map Name.Name Int) - - -lookupEnum :: Word8 -> Name.Name -> Enums -> (Int, Enums) -lookupEnum word var allEnums = - let - enums = - Map.findWithDefault Map.empty word allEnums - in - case Map.lookup var enums of - Just n -> - ( n, allEnums ) - - Nothing -> - let n = Map.size enums in - ( n, Map.insert word (Map.insert var n enums) allEnums ) - - - --- PROCESS IMPORTS - - -type VarTable = - Map.Map Name.Name Chunk - - -toVarTable :: Pkg.Name -> Foreigns -> [Src.Import] -> VarTable -toVarTable pkg foreigns imports = - List.foldl' (addImport pkg foreigns) Map.empty imports - - -addImport :: Pkg.Name -> Foreigns -> VarTable -> Src.Import -> VarTable -addImport pkg foreigns vtable (Src.Import (A.At _ importName) maybeAlias exposing) = - if Name.isKernel importName then - case maybeAlias of - Just _ -> - error ("cannot use `as` with kernel import of: " ++ Name.toChars importName) - - Nothing -> - let - home = Name.getKernel importName - add table name = - Map.insert (Name.sepBy 0x5F {-_-} home name) (JsVar home name) table - in - List.foldl' add vtable (toNames exposing) - - else - let - home = ModuleName.Canonical (Map.findWithDefault pkg importName foreigns) importName - prefix = toPrefix importName maybeAlias - add table name = - Map.insert (Name.sepBy 0x5F {-_-} prefix name) (ElmVar home name) table - in - List.foldl' add vtable (toNames exposing) - - -toPrefix :: Name.Name -> Maybe Name.Name -> Name.Name -toPrefix home maybeAlias = - case maybeAlias of - Just alias -> - alias - - Nothing -> - if Name.hasDot home then - error ("kernel imports with dots need an alias: " ++ show (Name.toChars home)) - else - home - - -toNames :: Src.Exposing -> [Name.Name] -toNames exposing = - case exposing of - Src.Open -> - error "cannot have `exposing (..)` in kernel code." - - Src.Explicit exposedList -> - map toName exposedList - - -toName :: Src.Exposed -> Name.Name -toName exposed = - case exposed of - Src.Lower (A.At _ name) -> - name - - Src.Upper (A.At _ name) Src.Private -> - name - - Src.Upper _ (Src.Public _) -> - error "cannot have Maybe(..) syntax in kernel code header" - - Src.Operator _ _ -> - error "cannot use binops in kernel code" - - - --- BINARY - - -instance Binary Chunk where - put chunk = - case chunk of - JS a -> putWord8 0 >> put a - ElmVar a b -> putWord8 1 >> put a >> put b - JsVar a b -> putWord8 2 >> put a >> put b - ElmField a -> putWord8 3 >> put a - JsField a -> putWord8 4 >> put a - JsEnum a -> putWord8 5 >> put a - Debug -> putWord8 6 - Prod -> putWord8 7 - - get = - do word <- getWord8 - case word of - 0 -> liftM JS get - 1 -> liftM2 ElmVar get get - 2 -> liftM2 JsVar get get - 3 -> liftM ElmField get - 4 -> liftM JsField get - 5 -> liftM JsEnum get - 6 -> return Debug - 7 -> return Prod - _ -> error "problem deserializing Elm.Kernel.Chunk" diff --git a/compiler/src/Elm/Licenses.hs b/compiler/src/Elm/Licenses.hs deleted file mode 100644 index 598107a47f..0000000000 --- a/compiler/src/Elm/Licenses.hs +++ /dev/null @@ -1,185 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE OverloadedStrings #-} -module Elm.Licenses - ( License - , bsd3 - , encode - , decoder - ) - where - - -import qualified Data.Map as Map -import qualified Data.Utf8 as Utf8 - -import qualified Json.Decode as D -import qualified Json.Encode as E -import qualified Json.String as Json -import qualified Reporting.Suggest as Suggest - - - --- LICENCES - - -newtype License = - License Json.String - - -bsd3 :: License -bsd3 = - License (Json.fromChars "BSD-3-Clause") - - -encode :: License -> E.Value -encode (License code) = - E.string code - - -decoder :: (Json.String -> [Json.String] -> e) -> D.Decoder e License -decoder toError = - do str <- D.string - case check str of - Right license -> - return license - - Left suggestions -> - D.failure (toError str suggestions) - - - --- CHECK - - -check :: Json.String -> Either [Json.String] License -check givenCode = - if Map.member givenCode osiApprovedSpdxLicenses then - Right (License givenCode) - - else - let - pairs = - map (\code -> (code, Json.toChars code)) (Map.keys osiApprovedSpdxLicenses) - ++ - Map.toList osiApprovedSpdxLicenses - in - Left $ map fst $ take 4 $ - Suggest.sort (Utf8.toChars givenCode) snd pairs - - - --- LIST OF LICENCES - - -(==>) :: [Char] -> [Char] -> (Json.String, [Char]) -(==>) code fullName = - ( Json.fromChars code, fullName ) - - --- --- OSI approved licenses in SPDX format. --- --- -osiApprovedSpdxLicenses :: Map.Map Json.String [Char] -osiApprovedSpdxLicenses = - Map.fromList - [ "0BSD" ==> "BSD Zero Clause License" - , "AAL" ==> "Attribution Assurance License" - , "AFL-1.1" ==> "Academic Free License v1.1" - , "AFL-1.2" ==> "Academic Free License v1.2" - , "AFL-2.0" ==> "Academic Free License v2.0" - , "AFL-2.1" ==> "Academic Free License v2.1" - , "AFL-3.0" ==> "Academic Free License v3.0" - , "AGPL-3.0" ==> "GNU Affero General Public License v3.0" - , "Apache-1.1" ==> "Apache License 1.1" - , "Apache-2.0" ==> "Apache License 2.0" - , "APL-1.0" ==> "Adaptive Public License 1.0" - , "APSL-1.0" ==> "Apple Public Source License 1.0" - , "APSL-1.1" ==> "Apple Public Source License 1.1" - , "APSL-1.2" ==> "Apple Public Source License 1.2" - , "APSL-2.0" ==> "Apple Public Source License 2.0" - , "Artistic-1.0" ==> "Artistic License 1.0" - , "Artistic-1.0-cl8" ==> "Artistic License 1.0 w/clause 8" - , "Artistic-1.0-Perl" ==> "Artistic License 1.0 (Perl)" - , "Artistic-2.0" ==> "Artistic License 2.0" - , "BSD-2-Clause" ==> "BSD 2-clause \"Simplified\" License" - , "BSD-3-Clause" ==> "BSD 3-clause \"New\" or \"Revised\" License" - , "BSL-1.0" ==> "Boost Software License 1.0" - , "CATOSL-1.1" ==> "Computer Associates Trusted Open Source License 1.1" - , "CDDL-1.0" ==> "Common Development and Distribution License 1.0" - , "CECILL-2.1" ==> "CeCILL Free Software License Agreement v2.1" - , "CNRI-Python" ==> "CNRI Python License" - , "CPAL-1.0" ==> "Common Public Attribution License 1.0" - , "CPL-1.0" ==> "Common Public License 1.0" - , "CUA-OPL-1.0" ==> "CUA Office Public License v1.0" - , "ECL-1.0" ==> "Educational Community License v1.0" - , "ECL-2.0" ==> "Educational Community License v2.0" - , "EFL-1.0" ==> "Eiffel Forum License v1.0" - , "EFL-2.0" ==> "Eiffel Forum License v2.0" - , "Entessa" ==> "Entessa Public License v1.0" - , "EPL-1.0" ==> "Eclipse Public License 1.0" - , "EUDatagrid" ==> "EU DataGrid Software License" - , "EUPL-1.1" ==> "European Union Public License 1.1" - , "Fair" ==> "Fair License" - , "Frameworx-1.0" ==> "Frameworx Open License 1.0" - , "GPL-2.0" ==> "GNU General Public License v2.0 only" - , "GPL-3.0" ==> "GNU General Public License v3.0 only" - , "HPND" ==> "Historic Permission Notice and Disclaimer" - , "Intel" ==> "Intel Open Source License" - , "IPA" ==> "IPA Font License" - , "IPL-1.0" ==> "IBM Public License v1.0" - , "ISC" ==> "ISC License" - , "LGPL-2.0" ==> "GNU Library General Public License v2 only" - , "LGPL-2.1" ==> "GNU Lesser General Public License v2.1 only" - , "LGPL-3.0" ==> "GNU Lesser General Public License v3.0 only" - , "LiLiQ-P-1.1" ==> "Licence Libre du Québec – Permissive version 1.1" - , "LiLiQ-R-1.1" ==> "Licence Libre du Québec – Réciprocité version 1.1" - , "LiLiQ-Rplus-1.1" ==> "Licence Libre du Québec – Réciprocité forte version 1.1" - , "LPL-1.0" ==> "Lucent Public License Version 1.0" - , "LPL-1.02" ==> "Lucent Public License v1.02" - , "LPPL-1.3c" ==> "LaTeX Project Public License v1.3c" - , "MirOS" ==> "MirOS Licence" - , "MIT" ==> "MIT License" - , "Motosoto" ==> "Motosoto License" - , "MPL-1.0" ==> "Mozilla Public License 1.0" - , "MPL-1.1" ==> "Mozilla Public License 1.1" - , "MPL-2.0" ==> "Mozilla Public License 2.0" - , "MPL-2.0-no-copyleft-exception" ==> "Mozilla Public License 2.0 (no copyleft exception)" - , "MS-PL" ==> "Microsoft Public License" - , "MS-RL" ==> "Microsoft Reciprocal License" - , "Multics" ==> "Multics License" - , "NASA-1.3" ==> "NASA Open Source Agreement 1.3" - , "Naumen" ==> "Naumen Public License" - , "NCSA" ==> "University of Illinois/NCSA Open Source License" - , "NGPL" ==> "Nethack General Public License" - , "Nokia" ==> "Nokia Open Source License" - , "NPOSL-3.0" ==> "Non-Profit Open Software License 3.0" - , "NTP" ==> "NTP License" - , "OCLC-2.0" ==> "OCLC Research Public License 2.0" - , "OFL-1.1" ==> "SIL Open Font License 1.1" - , "OGTSL" ==> "Open Group Test Suite License" - , "OSET-PL-2.1" ==> "OSET Public License version 2.1" - , "OSL-1.0" ==> "Open Software License 1.0" - , "OSL-2.0" ==> "Open Software License 2.0" - , "OSL-2.1" ==> "Open Software License 2.1" - , "OSL-3.0" ==> "Open Software License 3.0" - , "PHP-3.0" ==> "PHP License v3.0" - , "PostgreSQL" ==> "PostgreSQL License" - , "Python-2.0" ==> "Python License 2.0" - , "QPL-1.0" ==> "Q Public License 1.0" - , "RPL-1.1" ==> "Reciprocal Public License 1.1" - , "RPL-1.5" ==> "Reciprocal Public License 1.5" - , "RPSL-1.0" ==> "RealNetworks Public Source License v1.0" - , "RSCPL" ==> "Ricoh Source Code Public License" - , "SimPL-2.0" ==> "Simple Public License 2.0" - , "SISSL" ==> "Sun Industry Standards Source License v1.1" - , "Sleepycat" ==> "Sleepycat License" - , "SPL-1.0" ==> "Sun Public License v1.0" - , "UPL-1.0" ==> "Universal Permissive License v1.0" - , "VSL-1.0" ==> "Vovida Software License v1.0" - , "W3C" ==> "W3C Software Notice and License (2002-12-31)" - , "Watcom-1.0" ==> "Sybase Open Watcom Public License 1.0" - , "Xnet" ==> "X.Net License" - , "Zlib" ==> "zlib License" - , "ZPL-2.0" ==> "Zope Public License 2.0" - ] diff --git a/compiler/src/Elm/Magnitude.hs b/compiler/src/Elm/Magnitude.hs deleted file mode 100644 index 1023f6fb00..0000000000 --- a/compiler/src/Elm/Magnitude.hs +++ /dev/null @@ -1,24 +0,0 @@ -module Elm.Magnitude - ( Magnitude(..) - , toChars - ) - where - - - --- MAGNITUDE - - -data Magnitude - = PATCH - | MINOR - | MAJOR - deriving (Eq, Ord) - - -toChars :: Magnitude -> String -toChars magnitude = - case magnitude of - PATCH -> "PATCH" - MINOR -> "MINOR" - MAJOR -> "MAJOR" diff --git a/compiler/src/Elm/ModuleName.hs b/compiler/src/Elm/ModuleName.hs deleted file mode 100644 index f4ca405b0d..0000000000 --- a/compiler/src/Elm/ModuleName.hs +++ /dev/null @@ -1,287 +0,0 @@ -{-# LANGUAGE BangPatterns, OverloadedStrings, UnboxedTuples #-} -module Elm.ModuleName - ( Raw - , toChars - , toFilePath - , toHyphenPath - -- - , encode - , decoder - -- - , Canonical(..) - , basics, char, string - , maybe, result, list, array, dict, tuple - , platform, cmd, sub - , debug, bitwise - , virtualDom - , jsonDecode, jsonEncode - , webgl, texture, vector2, vector3, vector4, matrix4 - ) - where - - -import Control.Monad (liftM2) -import Data.Binary (Binary(..)) -import qualified Data.Name as Name -import qualified Data.Utf8 as Utf8 -import Data.Word (Word8) -import Foreign.Ptr (Ptr, plusPtr, minusPtr) -import Prelude hiding (maybe) -import qualified System.FilePath as FP - -import qualified Elm.Package as Pkg -import qualified Json.Decode as D -import qualified Json.Encode as E -import qualified Parse.Variable as Var -import qualified Parse.Primitives as P -import Parse.Primitives (Row, Col) - - - --- RAW - - -type Raw = Name.Name - - -toChars :: Raw -> String -toChars = - Name.toChars - - -toFilePath :: Raw -> FilePath -toFilePath name = - map (\c -> if c == '.' then FP.pathSeparator else c) (Name.toChars name) - - -toHyphenPath :: Raw -> FilePath -toHyphenPath name = - map (\c -> if c == '.' then '-' else c) (Name.toChars name) - - - --- JSON - - -encode :: Raw -> E.Value -encode = - E.name - - -decoder :: D.Decoder (Row, Col) Raw -decoder = - D.customString parser (,) - - - --- PARSER - - -parser :: P.Parser (Row, Col) Raw -parser = - P.Parser $ \(P.State src pos end indent row col) cok _ cerr eerr -> - let - (# isGood, newPos, newCol #) = chompStart pos end col - in - if isGood && minusPtr newPos pos < 256 then - let !newState = P.State src newPos end indent row newCol in - cok (Utf8.fromPtr pos newPos) newState - - else if col == newCol then - eerr row newCol (,) - - else - cerr row newCol (,) - - -chompStart :: Ptr Word8 -> Ptr Word8 -> Col -> (# Bool, Ptr Word8, Col #) -chompStart pos end col = - let - !width = Var.getUpperWidth pos end - in - if width == 0 then - (# False, pos, col #) - else - chompInner (plusPtr pos width) end (col + 1) - - -chompInner :: Ptr Word8 -> Ptr Word8 -> Col -> (# Bool, Ptr Word8, Col #) -chompInner pos end col = - if pos >= end then - (# True, pos, col #) - else - let - !word = P.unsafeIndex pos - !width = Var.getInnerWidthHelp pos end word - in - if width == 0 then - if word == 0x2E {-.-} then - chompStart (plusPtr pos 1) end (col + 1) - else - (# True, pos, col #) - else - chompInner (plusPtr pos width) end (col + 1) - - - --- CANONICAL - - -data Canonical = - Canonical - { _package :: !Pkg.Name - , _module :: !Name.Name - } - - - --- INSTANCES - - -instance Eq Canonical where - (==) (Canonical pkg1 name1) (Canonical pkg2 name2) = - name1 == name2 && pkg1 == pkg2 - - -instance Ord Canonical where - compare (Canonical pkg1 name1) (Canonical pkg2 name2) = - case compare name1 name2 of - LT -> LT - EQ -> compare pkg1 pkg2 - GT -> GT - - -instance Binary Canonical where - put (Canonical a b) = put a >> put b - get = liftM2 Canonical get get - - - --- CORE - - -{-# NOINLINE basics #-} -basics :: Canonical -basics = Canonical Pkg.core Name.basics - - -{-# NOINLINE char #-} -char :: Canonical -char = Canonical Pkg.core Name.char - - -{-# NOINLINE string #-} -string :: Canonical -string = Canonical Pkg.core Name.string - - -{-# NOINLINE maybe #-} -maybe :: Canonical -maybe = Canonical Pkg.core Name.maybe - - -{-# NOINLINE result #-} -result :: Canonical -result = Canonical Pkg.core Name.result - - -{-# NOINLINE list #-} -list :: Canonical -list = Canonical Pkg.core Name.list - - -{-# NOINLINE array #-} -array :: Canonical -array = Canonical Pkg.core Name.array - - -{-# NOINLINE dict #-} -dict :: Canonical -dict = Canonical Pkg.core Name.dict - - -{-# NOINLINE tuple #-} -tuple :: Canonical -tuple = Canonical Pkg.core Name.tuple - - -{-# NOINLINE platform #-} -platform :: Canonical -platform = Canonical Pkg.core Name.platform - - -{-# NOINLINE cmd #-} -cmd :: Canonical -cmd = Canonical Pkg.core "Platform.Cmd" - - -{-# NOINLINE sub #-} -sub :: Canonical -sub = Canonical Pkg.core "Platform.Sub" - - -{-# NOINLINE debug #-} -debug :: Canonical -debug = Canonical Pkg.core Name.debug - - -{-# NOINLINE bitwise #-} -bitwise :: Canonical -bitwise = Canonical Pkg.core Name.bitwise - - - --- HTML - - -{-# NOINLINE virtualDom #-} -virtualDom :: Canonical -virtualDom = Canonical Pkg.virtualDom Name.virtualDom - - - --- JSON - - -{-# NOINLINE jsonDecode #-} -jsonDecode :: Canonical -jsonDecode = Canonical Pkg.json "Json.Decode" - - -{-# NOINLINE jsonEncode #-} -jsonEncode :: Canonical -jsonEncode = Canonical Pkg.json "Json.Encode" - - - --- WEBGL - - -{-# NOINLINE webgl #-} -webgl :: Canonical -webgl = Canonical Pkg.webgl "WebGL" - - -{-# NOINLINE texture #-} -texture :: Canonical -texture = Canonical Pkg.webgl "WebGL.Texture" - - -{-# NOINLINE vector2 #-} -vector2 :: Canonical -vector2 = Canonical Pkg.linearAlgebra "Math.Vector2" - - -{-# NOINLINE vector3 #-} -vector3 :: Canonical -vector3 = Canonical Pkg.linearAlgebra "Math.Vector3" - - -{-# NOINLINE vector4 #-} -vector4 :: Canonical -vector4 = Canonical Pkg.linearAlgebra "Math.Vector4" - - -{-# NOINLINE matrix4 #-} -matrix4 :: Canonical -matrix4 = Canonical Pkg.linearAlgebra "Math.Matrix4" diff --git a/compiler/src/Elm/Package.hs b/compiler/src/Elm/Package.hs deleted file mode 100644 index 406bb80f4c..0000000000 --- a/compiler/src/Elm/Package.hs +++ /dev/null @@ -1,374 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE BangPatterns, EmptyDataDecls, FlexibleInstances, UnboxedTuples #-} -module Elm.Package - ( Name(..) - , Author - , Project - , Canonical(..) - , isKernel - , toChars - , toUrl - , toFilePath - , toJsonString - -- - , dummyName, kernel, core - , browser, virtualDom, html - , json, http, url - , webgl, linearAlgebra - -- - , suggestions - , nearbyNames - -- - , decoder - , encode - , keyDecoder - -- - , parser - ) - where - - -import Control.Monad (liftM2) -import Data.Binary (Binary, get, put) -import qualified Data.Coerce as Coerce -import qualified Data.List as List -import qualified Data.Map as Map -import qualified Data.Name as Name -import Data.Monoid ((<>)) -import qualified Data.Utf8 as Utf8 -import Data.Word (Word8) -import Foreign.Ptr (Ptr, plusPtr, minusPtr) -import System.FilePath (()) - -import qualified Elm.Version as V -import qualified Json.Decode as D -import qualified Json.Encode as E -import qualified Json.String as Json -import qualified Parse.Primitives as P -import Parse.Primitives (Row, Col) -import qualified Reporting.Suggest as Suggest - - - --- PACKGE NAMES - - -data Name = - Name - { _author :: !Author - , _project :: !Project - } - deriving (Ord) - - -type Author = Utf8.Utf8 AUTHOR -type Project = Utf8.Utf8 PROJECT - -data AUTHOR -data PROJECT - - -data Canonical = - Canonical - { _name :: !Name - , _version :: !V.Version - } - deriving (Ord) - - - --- HELPERS - - -isKernel :: Name -> Bool -isKernel (Name author _) = - author == elm || author == elm_explorations - - -toChars :: Name -> String -toChars (Name author project) = - Utf8.toChars author <> "/" <> Utf8.toChars project - - -toUrl :: Name -> String -toUrl (Name author project) = - Utf8.toChars author ++ "/" ++ Utf8.toChars project - - -toFilePath :: Name -> FilePath -toFilePath (Name author project) = - Utf8.toChars author Utf8.toChars project - - -toJsonString :: Name -> Json.String -toJsonString (Name author project) = - Utf8.join 0x2F {-/-} [ Coerce.coerce author, Coerce.coerce project ] - - - --- COMMON PACKAGE NAMES - - -toName :: Author -> [Char] -> Name -toName author project = - Name author (Utf8.fromChars project) - - -{-# NOINLINE dummyName #-} -dummyName :: Name -dummyName = - toName (Utf8.fromChars "author") "project" - - -{-# NOINLINE kernel #-} -kernel :: Name -kernel = - toName elm "kernel" - - -{-# NOINLINE core #-} -core :: Name -core = - toName elm "core" - - -{-# NOINLINE browser #-} -browser :: Name -browser = - toName elm "browser" - - -{-# NOINLINE virtualDom #-} -virtualDom :: Name -virtualDom = - toName elm "virtual-dom" - - -{-# NOINLINE html #-} -html :: Name -html = - toName elm "html" - - -{-# NOINLINE json #-} -json :: Name -json = - toName elm "json" - - -{-# NOINLINE http #-} -http :: Name -http = - toName elm "http" - - -{-# NOINLINE url #-} -url :: Name -url = - toName elm "url" - - -{-# NOINLINE webgl #-} -webgl :: Name -webgl = - toName elm_explorations "webgl" - - -{-# NOINLINE linearAlgebra #-} -linearAlgebra :: Name -linearAlgebra = - toName elm_explorations "linear-algebra" - - -{-# NOINLINE elm #-} -elm :: Author -elm = - Utf8.fromChars "elm" - - -{-# NOINLINE elm_explorations #-} -elm_explorations :: Author -elm_explorations = - Utf8.fromChars "elm-explorations" - - - --- PACKAGE SUGGESTIONS - - -suggestions :: Map.Map Name.Name Name -suggestions = - let - random = toName elm "random" - time = toName elm "time" - file = toName elm "file" - in - Map.fromList - [ "Browser" ==> browser - , "File" ==> file - , "File.Download" ==> file - , "File.Select" ==> file - , "Html" ==> html - , "Html.Attributes" ==> html - , "Html.Events" ==> html - , "Http" ==> http - , "Json.Decode" ==> json - , "Json.Encode" ==> json - , "Random" ==> random - , "Time" ==> time - , "Url.Parser" ==> url - , "Url" ==> url - ] - - -(==>) :: [Char] -> Name -> (Name.Name, Name) -(==>) moduleName package = - ( Utf8.fromChars moduleName, package ) - - - --- NEARBY NAMES - - -nearbyNames :: Name -> [Name] -> [Name] -nearbyNames (Name author1 project1) possibleNames = - let - authorDist = authorDistance (Utf8.toChars author1) - projectDist = projectDistance (Utf8.toChars project1) - - nameDistance (Name author2 project2) = - authorDist author2 + projectDist project2 - in - take 4 $ List.sortOn nameDistance possibleNames - - -authorDistance :: [Char] -> Author -> Int -authorDistance given possibility = - if possibility == elm || possibility == elm_explorations - then 0 - else abs (Suggest.distance given (Utf8.toChars possibility)) - - -projectDistance :: [Char] -> Project -> Int -projectDistance given possibility = - abs (Suggest.distance given (Utf8.toChars possibility)) - - - --- INSTANCES - - -instance Eq Name where - (==) (Name author1 project1) (Name author2 project2) = - project1 == project2 && author1 == author2 - - -instance Eq Canonical where - (==) (Canonical package1 version1) (Canonical package2 version2) = - version1 == version2 && package1 == package2 - - - --- BINARY - - -instance Binary Name where -- PERF try storing as a Word16 - get = liftM2 Name Utf8.getUnder256 Utf8.getUnder256 - put (Name a b) = Utf8.putUnder256 a >> Utf8.putUnder256 b - - -instance Binary Canonical where - get = liftM2 Canonical get get - put (Canonical a b) = put a >> put b - - - --- JSON - - -decoder :: D.Decoder (Row, Col) Name -decoder = - D.customString parser (,) - - -encode :: Name -> E.Value -encode name = - E.chars (toChars name) - - -keyDecoder :: (Row -> Col -> x) -> D.KeyDecoder x Name -keyDecoder toError = - let - keyParser = - P.specialize (\(r,c) _ _ -> toError r c) parser - in - D.KeyDecoder keyParser toError - - - --- PARSER - - -parser :: P.Parser (Row, Col) Name -parser = - do author <- parseName isAlphaOrDigit isAlphaOrDigit - P.word1 0x2F {-/-} (,) - project <- parseName isLower isLowerOrDigit - return (Name author project) - - -parseName :: (Word8 -> Bool) -> (Word8 -> Bool) -> P.Parser (Row, Col) (Utf8.Utf8 t) -parseName isGoodStart isGoodInner = - P.Parser $ \(P.State src pos end indent row col) cok _ cerr eerr -> - if pos >= end then - eerr row col (,) - else - let !word = P.unsafeIndex pos in - if not (isGoodStart word) then - eerr row col (,) - else - let - (# isGood, newPos #) = chompName isGoodInner (plusPtr pos 1) end False - !len = fromIntegral (minusPtr newPos pos) - !newCol = col + len - in - if isGood && len < 256 then - let !newState = P.State src newPos end indent row newCol in - cok (Utf8.fromPtr pos newPos) newState - else - cerr row newCol (,) - - -isLower :: Word8 -> Bool -isLower word = - 0x61 {-a-} <= word && word <= 0x7A {-z-} - - -isLowerOrDigit :: Word8 -> Bool -isLowerOrDigit word = - 0x61 {-a-} <= word && word <= 0x7A {-z-} - || 0x30 {-0-} <= word && word <= 0x39 {-9-} - - -isAlphaOrDigit :: Word8 -> Bool -isAlphaOrDigit word = - 0x61 {-a-} <= word && word <= 0x7A {-z-} - || 0x41 {-A-} <= word && word <= 0x5A {-Z-} - || 0x30 {-0-} <= word && word <= 0x39 {-9-} - - -chompName :: (Word8 -> Bool) -> Ptr Word8 -> Ptr Word8 -> Bool -> (# Bool, Ptr Word8 #) -chompName isGoodChar pos end prevWasDash = - if pos >= end then - (# not prevWasDash, pos #) - else - let !word = P.unsafeIndex pos in - if isGoodChar word then - chompName isGoodChar (plusPtr pos 1) end False - else if word == 0x2D {---} then - if prevWasDash then - (# False, pos #) - else - chompName isGoodChar (plusPtr pos 1) end True - else - (# True, pos #) diff --git a/compiler/src/Elm/String.hs b/compiler/src/Elm/String.hs deleted file mode 100644 index 5c43e616d6..0000000000 --- a/compiler/src/Elm/String.hs +++ /dev/null @@ -1,133 +0,0 @@ -{-# OPTIONS_GHC -Wall -fno-warn-name-shadowing #-} -{-# LANGUAGE BangPatterns, EmptyDataDecls, FlexibleInstances #-} -module Elm.String - ( String - , toChars - , toBuilder - , Chunk(..) - , fromChunks - ) - where - - -import Prelude hiding (String) -import Data.Binary (Binary, get, put) -import Data.Bits ((.&.), shiftR) -import qualified Data.ByteString.Builder as B -import qualified Data.Utf8 as Utf8 -import Data.Utf8 (MBA, newByteArray, copyFromPtr, freeze, writeWord8) -import GHC.Exts (RealWorld, Ptr) -import GHC.IO (stToIO, unsafeDupablePerformIO) -import GHC.ST (ST) -import GHC.Word (Word8) - - - --- STRINGS - - -type String = - Utf8.Utf8 ELM_STRING - - -data ELM_STRING - - - --- HELPERS - - -toChars :: String -> [Char] -toChars = - Utf8.toChars - - -{-# INLINE toBuilder #-} -toBuilder :: String -> B.Builder -toBuilder = - Utf8.toBuilder - - - --- FROM CHUNKS - - -data Chunk - = Slice (Ptr Word8) Int - | Escape Word8 - | CodePoint Int - - -fromChunks :: [Chunk] -> String -fromChunks chunks = - unsafeDupablePerformIO (stToIO ( - do let !len = sum (map chunkToWidth chunks) - mba <- newByteArray len - writeChunks mba 0 chunks - freeze mba - )) - - -chunkToWidth :: Chunk -> Int -chunkToWidth chunk = - case chunk of - Slice _ len -> len - Escape _ -> 2 - CodePoint c -> if c < 0xFFFF then 6 else 12 - - -writeChunks :: MBA RealWorld -> Int -> [Chunk] -> ST RealWorld () -writeChunks mba offset chunks = - case chunks of - [] -> - return () - - chunk : chunks -> - case chunk of - Slice ptr len -> - do copyFromPtr ptr mba offset len - let !newOffset = offset + len - writeChunks mba newOffset chunks - - Escape word -> - do writeWord8 mba offset 0x5C {- \ -} - writeWord8 mba (offset + 1) word - let !newOffset = offset + 2 - writeChunks mba newOffset chunks - - CodePoint code -> - if code < 0xFFFF then - do writeCode mba offset code - let !newOffset = offset + 6 - writeChunks mba newOffset chunks - else - do let (hi,lo) = divMod (code - 0x10000) 0x400 - writeCode mba (offset ) (hi + 0xD800) - writeCode mba (offset + 6) (lo + 0xDC00) - let !newOffset = offset + 12 - writeChunks mba newOffset chunks - - -writeCode :: MBA RealWorld -> Int -> Int -> ST RealWorld () -writeCode mba offset code = - do writeWord8 mba offset 0x5C {- \ -} - writeWord8 mba (offset + 1) 0x75 {- u -} - writeHex mba (offset + 2) (shiftR code 12) - writeHex mba (offset + 3) (shiftR code 8) - writeHex mba (offset + 4) (shiftR code 4) - writeHex mba (offset + 5) code - - -writeHex :: MBA RealWorld -> Int -> Int -> ST RealWorld () -writeHex mba !offset !bits = - do let !n = fromIntegral bits .&. 0x0F - writeWord8 mba offset (if n < 10 then 0x30 + n else 0x37 + n) - - - --- BINARY - - -instance Binary (Utf8.Utf8 ELM_STRING) where - get = Utf8.getVeryLong - put = Utf8.putVeryLong diff --git a/compiler/src/Elm/Version.hs b/compiler/src/Elm/Version.hs deleted file mode 100644 index 7a936efd15..0000000000 --- a/compiler/src/Elm/Version.hs +++ /dev/null @@ -1,196 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE BangPatterns, UnboxedTuples #-} -module Elm.Version - ( Version(..) - , one - , max - , compiler - , bumpPatch - , bumpMinor - , bumpMajor - , toChars - -- - , decoder - , encode - -- - , parser - ) - where - - -import Prelude hiding (max) -import Control.Monad (liftM3) -import Data.Binary (Binary, get, put, getWord8, putWord8) -import qualified Data.Version as Version -import Data.Word (Word8, Word16) -import Foreign.Ptr (Ptr, plusPtr, minusPtr) -import qualified Paths_elm - -import qualified Json.Decode as D -import qualified Json.Encode as E -import qualified Parse.Primitives as P -import Parse.Primitives (Row, Col) - - - --- VERSION - - -data Version = - Version - { _major :: {-# UNPACK #-} !Word16 - , _minor :: {-# UNPACK #-} !Word16 - , _patch :: {-# UNPACK #-} !Word16 - } - deriving (Eq, Ord) - - -one :: Version -one = - Version 1 0 0 - - -max :: Version -max = - Version maxBound 0 0 - - -compiler :: Version -compiler = - case map fromIntegral (Version.versionBranch Paths_elm.version) of - major : minor : patch : _ -> - Version major minor patch - - [major, minor] -> - Version major minor 0 - - [major] -> - Version major 0 0 - - [] -> - error "could not detect version of elm-compiler you are using" - - - --- BUMP - - -bumpPatch :: Version -> Version -bumpPatch (Version major minor patch) = - Version major minor (patch + 1) - - -bumpMinor :: Version -> Version -bumpMinor (Version major minor _patch) = - Version major (minor + 1) 0 - - -bumpMajor :: Version -> Version -bumpMajor (Version major _minor _patch) = - Version (major + 1) 0 0 - - - --- TO CHARS - - -toChars :: Version -> [Char] -toChars (Version major minor patch) = - show major ++ '.' : show minor ++ '.' : show patch - - - --- JSON - - -decoder :: D.Decoder (Row, Col) Version -decoder = - D.customString parser (,) - - -encode :: Version -> E.Value -encode version = - E.chars (toChars version) - - - --- BINARY - - -instance Binary Version where - get = - do word <- getWord8 - if word == 255 - then liftM3 Version get get get - else - do minor <- getWord8 - patch <- getWord8 - return (Version (fromIntegral word) (fromIntegral minor) (fromIntegral patch)) - - put (Version major minor patch) = - if major < 255 && minor < 256 && patch < 256 then - do putWord8 (fromIntegral major) - putWord8 (fromIntegral minor) - putWord8 (fromIntegral patch) - else - do putWord8 255 - put major - put minor - put patch - - - --- PARSER - - -parser :: P.Parser (Row, Col) Version -parser = - do major <- numberParser - P.word1 0x2E {-.-} (,) - minor <- numberParser - P.word1 0x2E {-.-} (,) - patch <- numberParser - return (Version major minor patch) - - -numberParser :: P.Parser (Row, Col) Word16 -numberParser = - P.Parser $ \(P.State src pos end indent row col) cok _ _ eerr -> - if pos >= end then - eerr row col (,) - else - let !word = P.unsafeIndex pos in - if word == 0x30 {-0-} then - - let - !newState = P.State src (plusPtr pos 1) end indent row (col + 1) - in - cok 0 newState - - else if isDigit word then - - let - (# total, newPos #) = chompWord16 (plusPtr pos 1) end (fromIntegral (word - 0x30)) - !newState = P.State src newPos end indent row (col + fromIntegral (minusPtr newPos pos)) - in - cok total newState - - else - eerr row col (,) - - -chompWord16 :: Ptr Word8 -> Ptr Word8 -> Word16 -> (# Word16, Ptr Word8 #) -chompWord16 pos end total = - if pos >= end then - (# total, pos #) - else - let !word = P.unsafeIndex pos in - if isDigit word then - chompWord16 (plusPtr pos 1) end (10 * total + fromIntegral (word - 0x30)) - else - (# total, pos #) - - -isDigit :: Word8 -> Bool -isDigit word = - 0x30 {-0-} <= word && word <= 0x39 {-9-} diff --git a/compiler/src/Generate/JavaScript.hs b/compiler/src/Generate/JavaScript.hs deleted file mode 100644 index d8116f33fc..0000000000 --- a/compiler/src/Generate/JavaScript.hs +++ /dev/null @@ -1,590 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module Generate.JavaScript - ( generate - , generateForRepl - , generateForReplEndpoint - ) - where - - -import Prelude hiding (cycle, print) -import qualified Data.ByteString.Builder as B -import Data.Monoid ((<>)) -import qualified Data.List as List -import Data.Map ((!)) -import qualified Data.Map as Map -import qualified Data.Name as Name -import qualified Data.Set as Set -import qualified Data.Utf8 as Utf8 - -import qualified AST.Canonical as Can -import qualified AST.Optimized as Opt -import qualified Data.Index as Index -import qualified Elm.Kernel as K -import qualified Elm.ModuleName as ModuleName -import qualified Generate.JavaScript.Builder as JS -import qualified Generate.JavaScript.Expression as Expr -import qualified Generate.JavaScript.Functions as Functions -import qualified Generate.JavaScript.Name as JsName -import qualified Generate.Mode as Mode -import qualified Reporting.Doc as D -import qualified Reporting.Render.Type as RT -import qualified Reporting.Render.Type.Localizer as L - - - --- GENERATE - - -type Graph = Map.Map Opt.Global Opt.Node -type Mains = Map.Map ModuleName.Canonical Opt.Main - - -generate :: Mode.Mode -> Opt.GlobalGraph -> Mains -> B.Builder -generate mode (Opt.GlobalGraph graph _) mains = - let - state = Map.foldrWithKey (addMain mode graph) emptyState mains - in - "(function(scope){\n'use strict';" - <> Functions.functions - <> perfNote mode - <> stateToBuilder state - <> toMainExports mode mains - <> "}(this));" - - -addMain :: Mode.Mode -> Graph -> ModuleName.Canonical -> Opt.Main -> State -> State -addMain mode graph home _ state = - addGlobal mode graph state (Opt.Global home "main") - - -perfNote :: Mode.Mode -> B.Builder -perfNote mode = - case mode of - Mode.Prod _ -> - "" - - Mode.Dev Nothing -> - "console.warn('Compiled in DEV mode. Follow the advice at " - <> B.stringUtf8 (D.makeNakedLink "optimize") - <> " for better performance and smaller assets.');" - - Mode.Dev (Just _) -> - "console.warn('Compiled in DEBUG mode. Follow the advice at " - <> B.stringUtf8 (D.makeNakedLink "optimize") - <> " for better performance and smaller assets.');" - - - --- GENERATE FOR REPL - - -generateForRepl :: Bool -> L.Localizer -> Opt.GlobalGraph -> ModuleName.Canonical -> Name.Name -> Can.Annotation -> B.Builder -generateForRepl ansi localizer (Opt.GlobalGraph graph _) home name (Can.Forall _ tipe) = - let - mode = Mode.Dev Nothing - debugState = addGlobal mode graph emptyState (Opt.Global ModuleName.debug "toString") - evalState = addGlobal mode graph debugState (Opt.Global home name) - in - "process.on('uncaughtException', function(err) { process.stderr.write(err.toString() + '\\n'); process.exit(1); });" - <> Functions.functions - <> stateToBuilder evalState - <> print ansi localizer home name tipe - - -print :: Bool -> L.Localizer -> ModuleName.Canonical -> Name.Name -> Can.Type -> B.Builder -print ansi localizer home name tipe = - let - value = JsName.toBuilder (JsName.fromGlobal home name) - toString = JsName.toBuilder (JsName.fromKernel Name.debug "toAnsiString") - tipeDoc = RT.canToDoc localizer RT.None tipe - bool = if ansi then "true" else "false" - in - "var _value = " <> toString <> "(" <> bool <> ", " <> value <> ");\n\ - \var _type = " <> B.stringUtf8 (show (D.toString tipeDoc)) <> ";\n\ - \function _print(t) { console.log(_value + (" <> bool <> " ? '\x1b[90m' + t + '\x1b[0m' : t)); }\n\ - \if (_value.length + 3 + _type.length >= 80 || _type.indexOf('\\n') >= 0) {\n\ - \ _print('\\n : ' + _type.split('\\n').join('\\n '));\n\ - \} else {\n\ - \ _print(' : ' + _type);\n\ - \}\n" - - - --- GENERATE FOR REPL ENDPOINT - - -generateForReplEndpoint :: L.Localizer -> Opt.GlobalGraph -> ModuleName.Canonical -> Maybe Name.Name -> Can.Annotation -> B.Builder -generateForReplEndpoint localizer (Opt.GlobalGraph graph _) home maybeName (Can.Forall _ tipe) = - let - name = maybe Name.replValueToPrint id maybeName - mode = Mode.Dev Nothing - debugState = addGlobal mode graph emptyState (Opt.Global ModuleName.debug "toString") - evalState = addGlobal mode graph debugState (Opt.Global home name) - in - Functions.functions - <> stateToBuilder evalState - <> postMessage localizer home maybeName tipe - - -postMessage :: L.Localizer -> ModuleName.Canonical -> Maybe Name.Name -> Can.Type -> B.Builder -postMessage localizer home maybeName tipe = - let - name = maybe Name.replValueToPrint id maybeName - value = JsName.toBuilder (JsName.fromGlobal home name) - toString = JsName.toBuilder (JsName.fromKernel Name.debug "toAnsiString") - tipeDoc = RT.canToDoc localizer RT.None tipe - toName n = "\"" <> Name.toBuilder n <> "\"" - in - "self.postMessage({\n\ - \ name: " <> maybe "null" toName maybeName <> ",\n\ - \ value: " <> toString <> "(true, " <> value <> "),\n\ - \ type: " <> B.stringUtf8 (show (D.toString tipeDoc)) <> "\n\ - \});\n" - - - --- GRAPH TRAVERSAL STATE - - -data State = - State - { _revKernels :: [B.Builder] - , _revBuilders :: [B.Builder] - , _seenGlobals :: Set.Set Opt.Global - } - - -emptyState :: State -emptyState = - State mempty [] Set.empty - - -stateToBuilder :: State -> B.Builder -stateToBuilder (State revKernels revBuilders _) = - prependBuilders revKernels (prependBuilders revBuilders mempty) - - -prependBuilders :: [B.Builder] -> B.Builder -> B.Builder -prependBuilders revBuilders monolith = - List.foldl' (\m b -> b <> m) monolith revBuilders - - - --- ADD DEPENDENCIES - - -addGlobal :: Mode.Mode -> Graph -> State -> Opt.Global -> State -addGlobal mode graph state@(State revKernels builders seen) global = - if Set.member global seen then - state - else - addGlobalHelp mode graph global $ - State revKernels builders (Set.insert global seen) - - -addGlobalHelp :: Mode.Mode -> Graph -> Opt.Global -> State -> State -addGlobalHelp mode graph global state = - let - addDeps deps someState = - Set.foldl' (addGlobal mode graph) someState deps - in - case graph ! global of - Opt.Define expr deps -> - addStmt (addDeps deps state) ( - var global (Expr.generate mode expr) - ) - - Opt.DefineTailFunc argNames body deps -> - addStmt (addDeps deps state) ( - let (Opt.Global _ name) = global in - var global (Expr.generateTailDef mode name argNames body) - ) - - Opt.Ctor index arity -> - addStmt state ( - var global (Expr.generateCtor mode global index arity) - ) - - Opt.Link linkedGlobal -> - addGlobal mode graph state linkedGlobal - - Opt.Cycle names values functions deps -> - addStmt (addDeps deps state) ( - generateCycle mode global names values functions - ) - - Opt.Manager effectsType -> - generateManager mode graph global effectsType state - - Opt.Kernel chunks deps -> - if isDebugger global && not (Mode.isDebug mode) then - state - else - addKernel (addDeps deps state) (generateKernel mode chunks) - - Opt.Enum index -> - addStmt state ( - generateEnum mode global index - ) - - Opt.Box -> - addStmt (addGlobal mode graph state identity) ( - generateBox mode global - ) - - Opt.PortIncoming decoder deps -> - addStmt (addDeps deps state) ( - generatePort mode global "incomingPort" decoder - ) - - Opt.PortOutgoing encoder deps -> - addStmt (addDeps deps state) ( - generatePort mode global "outgoingPort" encoder - ) - - -addStmt :: State -> JS.Stmt -> State -addStmt state stmt = - addBuilder state (JS.stmtToBuilder stmt) - - -addBuilder :: State -> B.Builder -> State -addBuilder (State revKernels revBuilders seen) builder = - State revKernels (builder:revBuilders) seen - - -addKernel :: State -> B.Builder -> State -addKernel (State revKernels revBuilders seen) kernel = - State (kernel:revKernels) revBuilders seen - - -var :: Opt.Global -> Expr.Code -> JS.Stmt -var (Opt.Global home name) code = - JS.Var (JsName.fromGlobal home name) (Expr.codeToExpr code) - - -isDebugger :: Opt.Global -> Bool -isDebugger (Opt.Global (ModuleName.Canonical _ home) _) = - home == Name.debugger - - - --- GENERATE CYCLES - - -generateCycle :: Mode.Mode -> Opt.Global -> [Name.Name] -> [(Name.Name, Opt.Expr)] -> [Opt.Def] -> JS.Stmt -generateCycle mode (Opt.Global home _) names values functions = - JS.Block - [ JS.Block $ map (generateCycleFunc mode home) functions - , JS.Block $ map (generateSafeCycle mode home) values - , case map (generateRealCycle home) values of - [] -> - JS.EmptyStmt - - realBlock@(_:_) -> - case mode of - Mode.Prod _ -> - JS.Block realBlock - - Mode.Dev _ -> - JS.Try (JS.Block realBlock) JsName.dollar $ JS.Throw $ JS.String $ - "Some top-level definitions from `" <> Name.toBuilder (ModuleName._module home) <> "` are causing infinite recursion:\\n" - <> drawCycle names - <> "\\n\\nThese errors are very tricky, so read " - <> B.stringUtf8 (D.makeNakedLink "bad-recursion") - <> " to learn how to fix it!" - ] - - -generateCycleFunc :: Mode.Mode -> ModuleName.Canonical -> Opt.Def -> JS.Stmt -generateCycleFunc mode home def = - case def of - Opt.Def name expr -> - JS.Var (JsName.fromGlobal home name) (Expr.codeToExpr (Expr.generate mode expr)) - - Opt.TailDef name args expr -> - JS.Var (JsName.fromGlobal home name) (Expr.codeToExpr (Expr.generateTailDef mode name args expr)) - - -generateSafeCycle :: Mode.Mode -> ModuleName.Canonical -> (Name.Name, Opt.Expr) -> JS.Stmt -generateSafeCycle mode home (name, expr) = - JS.FunctionStmt (JsName.fromCycle home name) [] $ - Expr.codeToStmtList (Expr.generate mode expr) - - -generateRealCycle :: ModuleName.Canonical -> (Name.Name, expr) -> JS.Stmt -generateRealCycle home (name, _) = - let - safeName = JsName.fromCycle home name - realName = JsName.fromGlobal home name - in - JS.Block - [ JS.Var realName (JS.Call (JS.Ref safeName) []) - , JS.ExprStmt $ JS.Assign (JS.LRef safeName) $ - JS.Function Nothing [] [ JS.Return (JS.Ref realName) ] - ] - - -drawCycle :: [Name.Name] -> B.Builder -drawCycle names = - let - topLine = "\\n ┌─────┐" - nameLine name = "\\n │ " <> Name.toBuilder name - midLine = "\\n │ ↓" - bottomLine = "\\n └─────┘" - in - mconcat (topLine : List.intersperse midLine (map nameLine names) ++ [ bottomLine ]) - - - --- GENERATE KERNEL - - -generateKernel :: Mode.Mode -> [K.Chunk] -> B.Builder -generateKernel mode chunks = - List.foldr (addChunk mode) mempty chunks - - -addChunk :: Mode.Mode -> K.Chunk -> B.Builder -> B.Builder -addChunk mode chunk builder = - case chunk of - K.JS javascript -> - B.byteString javascript <> builder - - K.ElmVar home name -> - JsName.toBuilder (JsName.fromGlobal home name) <> builder - - K.JsVar home name -> - JsName.toBuilder (JsName.fromKernel home name) <> builder - - K.ElmField name -> - JsName.toBuilder (Expr.generateField mode name) <> builder - - K.JsField int -> - JsName.toBuilder (JsName.fromInt int) <> builder - - K.JsEnum int -> - B.intDec int <> builder - - K.Debug -> - case mode of - Mode.Dev _ -> - builder - - Mode.Prod _ -> - "_UNUSED" <> builder - - K.Prod -> - case mode of - Mode.Dev _ -> - "_UNUSED" <> builder - - Mode.Prod _ -> - builder - - - --- GENERATE ENUM - - -generateEnum :: Mode.Mode -> Opt.Global -> Index.ZeroBased -> JS.Stmt -generateEnum mode global@(Opt.Global home name) index = - JS.Var (JsName.fromGlobal home name) $ - case mode of - Mode.Dev _ -> - Expr.codeToExpr (Expr.generateCtor mode global index 0) - - Mode.Prod _ -> - JS.Int (Index.toMachine index) - - - --- GENERATE BOX - - -generateBox :: Mode.Mode -> Opt.Global -> JS.Stmt -generateBox mode global@(Opt.Global home name) = - JS.Var (JsName.fromGlobal home name) $ - case mode of - Mode.Dev _ -> - Expr.codeToExpr (Expr.generateCtor mode global Index.first 1) - - Mode.Prod _ -> - JS.Ref (JsName.fromGlobal ModuleName.basics Name.identity) - - -{-# NOINLINE identity #-} -identity :: Opt.Global -identity = - Opt.Global ModuleName.basics Name.identity - - - --- GENERATE PORTS - - -generatePort :: Mode.Mode -> Opt.Global -> Name.Name -> Opt.Expr -> JS.Stmt -generatePort mode (Opt.Global home name) makePort converter = - JS.Var (JsName.fromGlobal home name) $ - JS.Call (JS.Ref (JsName.fromKernel Name.platform makePort)) - [ JS.String (Name.toBuilder name) - , Expr.codeToExpr (Expr.generate mode converter) - ] - - - --- GENERATE MANAGER - - -generateManager :: Mode.Mode -> Graph -> Opt.Global -> Opt.EffectsType -> State -> State -generateManager mode graph (Opt.Global home@(ModuleName.Canonical _ moduleName) _) effectsType state = - let - managerLVar = - JS.LBracket - (JS.Ref (JsName.fromKernel Name.platform "effectManagers")) - (JS.String (Name.toBuilder moduleName)) - - (deps, args, stmts) = - generateManagerHelp home effectsType - - createManager = - JS.ExprStmt $ JS.Assign managerLVar $ - JS.Call (JS.Ref (JsName.fromKernel Name.platform "createManager")) args - in - addStmt (List.foldl' (addGlobal mode graph) state deps) $ - JS.Block (createManager : stmts) - - -generateLeaf :: ModuleName.Canonical -> Name.Name -> JS.Stmt -generateLeaf home@(ModuleName.Canonical _ moduleName) name = - JS.Var (JsName.fromGlobal home name) $ - JS.Call leaf [ JS.String (Name.toBuilder moduleName) ] - - - -{-# NOINLINE leaf #-} -leaf :: JS.Expr -leaf = - JS.Ref (JsName.fromKernel Name.platform "leaf") - - -generateManagerHelp :: ModuleName.Canonical -> Opt.EffectsType -> ([Opt.Global], [JS.Expr], [JS.Stmt]) -generateManagerHelp home effectsType = - let - dep name = Opt.Global home name - ref name = JS.Ref (JsName.fromGlobal home name) - in - case effectsType of - Opt.Cmd -> - ( [ dep "init", dep "onEffects", dep "onSelfMsg", dep "cmdMap" ] - , [ ref "init", ref "onEffects", ref "onSelfMsg", ref "cmdMap" ] - , [ generateLeaf home "command" ] - ) - - Opt.Sub -> - ( [ dep "init", dep "onEffects", dep "onSelfMsg", dep "subMap" ] - , [ ref "init", ref "onEffects", ref "onSelfMsg", JS.Int 0, ref "subMap" ] - , [ generateLeaf home "subscription" ] - ) - - Opt.Fx -> - ( [ dep "init", dep "onEffects", dep "onSelfMsg", dep "cmdMap", dep "subMap" ] - , [ ref "init", ref "onEffects", ref "onSelfMsg", ref "cmdMap", ref "subMap" ] - , [ generateLeaf home "command" - , generateLeaf home "subscription" - ] - ) - - - --- MAIN EXPORTS - - -toMainExports :: Mode.Mode -> Mains -> B.Builder -toMainExports mode mains = - let - export = JsName.fromKernel Name.platform "export" - exports = generateExports mode (Map.foldrWithKey addToTrie emptyTrie mains) - in - JsName.toBuilder export <> "(" <> exports <> ");" - - -generateExports :: Mode.Mode -> Trie -> B.Builder -generateExports mode (Trie maybeMain subs) = - let - starter end = - case maybeMain of - Nothing -> - "{" - - Just (home, main) -> - "{'init':" - <> JS.exprToBuilder (Expr.generateMain mode home main) - <> end - in - case Map.toList subs of - [] -> - starter "" <> "}" - - (name, subTrie) : otherSubTries -> - starter "," <> - "'" <> Utf8.toBuilder name <> "':" - <> generateExports mode subTrie - <> List.foldl' (addSubTrie mode) "}" otherSubTries - - -addSubTrie :: Mode.Mode -> B.Builder -> (Name.Name, Trie) -> B.Builder -addSubTrie mode end (name, trie) = - ",'" <> Utf8.toBuilder name <> "':" <> generateExports mode trie <> end - - - --- BUILD TRIES - - -data Trie = - Trie - { _main :: Maybe (ModuleName.Canonical, Opt.Main) - , _subs :: Map.Map Name.Name Trie - } - - -emptyTrie :: Trie -emptyTrie = - Trie Nothing Map.empty - - -addToTrie :: ModuleName.Canonical -> Opt.Main -> Trie -> Trie -addToTrie home@(ModuleName.Canonical _ moduleName) main trie = - merge trie $ segmentsToTrie home (Name.splitDots moduleName) main - - -segmentsToTrie :: ModuleName.Canonical -> [Name.Name] -> Opt.Main -> Trie -segmentsToTrie home segments main = - case segments of - [] -> - Trie (Just (home, main)) Map.empty - - segment : otherSegments -> - Trie Nothing (Map.singleton segment (segmentsToTrie home otherSegments main)) - - -merge :: Trie -> Trie -> Trie -merge (Trie main1 subs1) (Trie main2 subs2) = - Trie - (checkedMerge main1 main2) - (Map.unionWith merge subs1 subs2) - - -checkedMerge :: Maybe a -> Maybe a -> Maybe a -checkedMerge a b = - case (a, b) of - (Nothing, main) -> - main - - (main, Nothing) -> - main - - (Just _, Just _) -> - error "cannot have two modules with the same name" diff --git a/compiler/src/Generate/JavaScript/Builder.hs b/compiler/src/Generate/JavaScript/Builder.hs deleted file mode 100644 index fde32cafb7..0000000000 --- a/compiler/src/Generate/JavaScript/Builder.hs +++ /dev/null @@ -1,530 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE OverloadedStrings #-} -module Generate.JavaScript.Builder - ( stmtToBuilder - , exprToBuilder - , Expr(..), LValue(..) - , Stmt(..), Case(..) - , InfixOp(..), PrefixOp(..) - ) - where - --- Based on the language-ecmascript package. --- https://hackage.haskell.org/package/language-ecmascript --- They did the hard work of reading the spec to figure out --- how all the types should fit together. - -import Prelude hiding (lines) -import qualified Data.List as List -import qualified Data.ByteString as BS -import Data.ByteString.Builder as B -import Data.Monoid ((<>)) -import qualified Generate.JavaScript.Name as Name -import Generate.JavaScript.Name (Name) -import qualified Json.Encode as Json - - - --- EXPRESSIONS - - --- NOTE: I tried making this create a B.Builder directly. --- --- The hope was that it'd allocate less and speed things up, but it seemed --- to be neutral for perf. --- --- The downside is that Generate.JavaScript.Expression inspects the --- structure of Expr and Stmt on some occassions to try to strip out --- unnecessary closures. I think these closures are already avoided --- by other logic in code gen these days, but I am not 100% certain. --- --- For this to be worth it, I think it would be necessary to avoid --- returning tuples when generating expressions. --- -data Expr - = String Builder - | Float Builder - | Int Int - | Bool Bool - | Null - | Json Json.Value - | Array [Expr] - | Object [(Name, Expr)] - | Ref Name - | Access Expr Name -- foo.bar - | Index Expr Expr -- foo[bar] - | Prefix PrefixOp Expr - | Infix InfixOp Expr Expr - | If Expr Expr Expr - | Assign LValue Expr - | Call Expr [Expr] - | Function (Maybe Name) [Name] [Stmt] - - -data LValue - = LRef Name - | LDot Expr Name - | LBracket Expr Expr - - - --- STATEMENTS - - -data Stmt - = Block [Stmt] - | EmptyStmt - | ExprStmt Expr - | IfStmt Expr Stmt Stmt - | Switch Expr [Case] - | While Expr Stmt - | Break (Maybe Name) - | Continue (Maybe Name) - | Labelled Name Stmt - | Try Stmt Name Stmt - | Throw Expr - | Return Expr - | Var Name Expr - | Vars [(Name, Expr)] - | FunctionStmt Name [Name] [Stmt] - - -data Case - = Case Expr [Stmt] - | Default [Stmt] - - - --- OPERATORS - - -data InfixOp - = OpAdd -- + - | OpSub -- - - | OpMul -- * - | OpDiv -- / - | OpMod -- % - | OpEq -- === - | OpNe -- !== - | OpLt -- < - | OpLe -- <= - | OpGt -- > - | OpGe -- >= - | OpAnd -- && - | OpOr -- || - | OpBitwiseAnd -- & - | OpBitwiseXor -- ^ - | OpBitwiseOr -- | - | OpLShift -- << - | OpSpRShift -- >> - | OpZfRShift -- >>> - - -data PrefixOp - = PrefixNot -- ! - | PrefixNegate -- - - | PrefixComplement -- ~ - - - --- ENCODE - - -stmtToBuilder :: Stmt -> Builder -stmtToBuilder stmts = - fromStmt levelZero stmts - - -exprToBuilder :: Expr -> Builder -exprToBuilder expr = - snd $ fromExpr levelZero Whatever expr - - - --- INDENT LEVEL - - -data Level = - Level Builder Level - - -levelZero :: Level -levelZero = - Level mempty (makeLevel 1 (BS.replicate 16 0x09 {-\t-})) - - -makeLevel :: Int -> BS.ByteString -> Level -makeLevel level oldTabs = - let - tabs = - if level <= BS.length oldTabs - then oldTabs - else BS.replicate (BS.length oldTabs * 2) 0x09 {-\t-} - in - Level (B.byteString (BS.take level tabs)) (makeLevel (level + 1) tabs) - - - --- HELPERS - - -commaSep :: [Builder] -> Builder -commaSep builders = - mconcat (List.intersperse ", " builders) - - -commaNewlineSep :: Level -> [Builder] -> Builder -commaNewlineSep (Level _ (Level deeperIndent _)) builders = - mconcat (List.intersperse (",\n" <> deeperIndent) builders) - - - --- STATEMENTS - - -fromStmtBlock :: Level -> [Stmt] -> Builder -fromStmtBlock level stmts = - mconcat (map (fromStmt level) stmts) - - -fromStmt :: Level -> Stmt -> Builder -fromStmt level@(Level indent nextLevel) statement = - case statement of - Block stmts -> - fromStmtBlock level stmts - - EmptyStmt -> - mempty - - ExprStmt expr -> - indent <> snd (fromExpr level Whatever expr) <> ";\n" - - IfStmt condition thenStmt elseStmt -> - mconcat - [ indent, "if (", snd (fromExpr level Whatever condition), ") {\n" - , fromStmt nextLevel thenStmt - , indent, "} else {\n" - , fromStmt nextLevel elseStmt - , indent, "}\n" - ] - - Switch expr clauses -> - mconcat - [ indent, "switch (", snd (fromExpr level Whatever expr), ") {\n" - , mconcat (map (fromClause nextLevel) clauses) - , indent, "}\n" - ] - - While expr stmt -> - mconcat - [ indent, "while (", snd (fromExpr level Whatever expr), ") {\n" - , fromStmt nextLevel stmt - , indent, "}\n" - ] - - Break Nothing -> - indent <> "break;\n" - - Break (Just label) -> - indent <> "break " <> Name.toBuilder label <> ";\n" - - Continue Nothing -> - indent <> "continue;\n" - - Continue (Just label) -> - indent <> "continue " <> Name.toBuilder label <> ";\n" - - Labelled label stmt -> - mconcat - [ indent, Name.toBuilder label, ":\n" - , fromStmt level stmt - ] - - Try tryStmt errorName catchStmt -> - mconcat - [ indent, "try {\n" - , fromStmt nextLevel tryStmt - , indent, "} catch (", Name.toBuilder errorName, ") {\n" - , fromStmt nextLevel catchStmt - , indent, "}\n" - ] - - Throw expr -> - indent <> "throw " <> snd (fromExpr level Whatever expr) <> ";" - - Return expr -> - indent <> "return " <> snd (fromExpr level Whatever expr) <> ";\n" - - Var name expr -> - indent <> "var " <> Name.toBuilder name <> " = " <> snd (fromExpr level Whatever expr) <> ";\n" - - Vars [] -> - mempty - - Vars vars -> - indent <> "var " <> commaNewlineSep level (map (varToBuilder level) vars) <> ";\n" - - FunctionStmt name args stmts -> - indent <> "function " <> Name.toBuilder name <> "(" <> commaSep (map Name.toBuilder args) <> ") {\n" - <> - fromStmtBlock nextLevel stmts - <> - indent <> "}\n" - - - --- SWITCH CLAUSES - - -fromClause :: Level -> Case -> Builder -fromClause level@(Level indent nextLevel) clause = - case clause of - Case expr stmts -> - indent <> "case " <> snd (fromExpr level Whatever expr) <> ":\n" - <> fromStmtBlock nextLevel stmts - - Default stmts -> - indent <> "default:\n" - <> fromStmtBlock nextLevel stmts - - - --- VAR DECLS - - -varToBuilder :: Level -> (Name, Expr) -> Builder -varToBuilder level (name, expr) = - Name.toBuilder name <> " = " <> snd (fromExpr level Whatever expr) - - - --- EXPRESSIONS - - -data Lines = One | Many deriving (Eq) - - -merge :: Lines -> Lines -> Lines -merge a b = - if a == Many || b == Many then Many else One - - -linesMap :: (a -> (Lines, b)) -> [a] -> (Bool, [b]) -linesMap func xs = - let - pairs = map func xs - in - ( any ((==) Many . fst) pairs - , map snd pairs - ) - - -data Grouping = Atomic | Whatever - - -parensFor :: Grouping -> Builder -> Builder -parensFor grouping builder = - case grouping of - Atomic -> - "(" <> builder <> ")" - - Whatever -> - builder - - -fromExpr :: Level -> Grouping -> Expr -> (Lines, Builder) -fromExpr level@(Level indent nextLevel@(Level deeperIndent _)) grouping expression = - case expression of - String string -> - ( One, "'" <> string <> "'" ) - - Float float -> - ( One, float ) - - Int n -> - ( One, B.intDec n ) - - Bool bool -> - ( One, if bool then "true" else "false" ) - - Null -> - ( One, "null" ) - - Json json -> - ( One, Json.encodeUgly json ) - - Array exprs -> - (,) Many $ - let - (anyMany, builders) = linesMap (fromExpr level Whatever) exprs - in - if anyMany then - "[\n" - <> deeperIndent - <> commaNewlineSep level builders - <> "\n" <> indent <> "]" - else - "[" <> commaSep builders <> "]" - - Object fields -> - (,) Many $ - let - (anyMany, builders) = linesMap (fromField nextLevel) fields - in - if anyMany then - "{\n" - <> deeperIndent - <> commaNewlineSep level builders - <> "\n" <> indent <> "}" - else - "{" <> commaSep builders <> "}" - - Ref name -> - ( One, Name.toBuilder name ) - - Access expr field -> - makeDot level expr field - - Index expr bracketedExpr -> - makeBracketed level expr bracketedExpr - - Prefix op expr -> - let - (lines, builder) = fromExpr level Atomic expr - in - ( lines - , parensFor grouping (fromPrefix op <> builder) - ) - - Infix op leftExpr rightExpr -> - let - (leftLines , left ) = fromExpr level Atomic leftExpr - (rightLines, right) = fromExpr level Atomic rightExpr - in - ( merge leftLines rightLines - , parensFor grouping (left <> fromInfix op <> right) - ) - - If condExpr thenExpr elseExpr -> - let - condB = snd (fromExpr level Atomic condExpr) - thenB = snd (fromExpr level Atomic thenExpr) - elseB = snd (fromExpr level Atomic elseExpr) - in - ( Many - , parensFor grouping (condB <> " ? " <> thenB <> " : " <> elseB) - ) - - Assign lValue expr -> - let - (leftLines , left ) = fromLValue level lValue - (rightLines, right) = fromExpr level Whatever expr - in - ( merge leftLines rightLines - , parensFor grouping (left <> " = " <> right) - ) - - Call function args -> - (,) Many $ - let - (_ , funcB) = fromExpr level Atomic function - (anyMany, argsB) = linesMap (fromExpr nextLevel Whatever) args - in - if anyMany then - funcB <> "(\n" <> deeperIndent <> commaNewlineSep level argsB <> ")" - else - funcB <> "(" <> commaSep argsB <> ")" - - Function maybeName args stmts -> - (,) Many $ - "function " <> maybe mempty Name.toBuilder maybeName <> "(" <> commaSep (map Name.toBuilder args) <> ") {\n" - <> - fromStmtBlock nextLevel stmts - <> - indent <> "}" - - - --- FIELDS - - -fromField :: Level -> (Name, Expr) -> (Lines, Builder) -fromField level (field, expr) = - let - (lines, builder) = fromExpr level Whatever expr - in - ( lines - , Name.toBuilder field <> ": " <> builder - ) - - - --- VALUES - - -fromLValue :: Level -> LValue -> (Lines, Builder) -fromLValue level lValue = - case lValue of - LRef name -> - (One, Name.toBuilder name) - - LDot expr field -> - makeDot level expr field - - LBracket expr bracketedExpr -> - makeBracketed level expr bracketedExpr - - -makeDot :: Level -> Expr -> Name -> (Lines, Builder) -makeDot level expr field = - let - (lines, builder) = fromExpr level Atomic expr - in - (lines, builder <> "." <> Name.toBuilder field) - - -makeBracketed :: Level -> Expr -> Expr -> (Lines, Builder) -makeBracketed level expr bracketedExpr = - let - (lines , builder ) = fromExpr level Atomic expr - (bracketedLines, bracketedBuilder) = fromExpr level Whatever bracketedExpr - in - ( merge lines bracketedLines - , builder <> "[" <> bracketedBuilder <> "]" - ) - - - --- OPERATORS - - -fromPrefix :: PrefixOp -> Builder -fromPrefix op = - case op of - PrefixNot -> "!" - PrefixNegate -> "-" - PrefixComplement -> "~" - - -fromInfix :: InfixOp -> Builder -fromInfix op = - case op of - OpAdd -> " + " - OpSub -> " - " - OpMul -> " * " - OpDiv -> " / " - OpMod -> " % " - OpEq -> " === " - OpNe -> " !== " - OpLt -> " < " - OpLe -> " <= " - OpGt -> " > " - OpGe -> " >= " - OpAnd -> " && " - OpOr -> " || " - OpBitwiseAnd -> " & " - OpBitwiseXor -> " ^ " - OpBitwiseOr -> " | " - OpLShift -> " << " - OpSpRShift -> " >> " - OpZfRShift -> " >>> " diff --git a/compiler/src/Generate/JavaScript/Expression.hs b/compiler/src/Generate/JavaScript/Expression.hs deleted file mode 100644 index ba7ab36636..0000000000 --- a/compiler/src/Generate/JavaScript/Expression.hs +++ /dev/null @@ -1,1070 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module Generate.JavaScript.Expression - ( generate - , generateCtor - , generateField - , generateTailDef - , generateMain - , Code - , codeToExpr - , codeToStmtList - ) - where - - -import qualified Data.IntMap as IntMap -import qualified Data.List as List -import Data.Map ((!)) -import qualified Data.Map as Map -import qualified Data.Name as Name -import qualified Data.Set as Set -import qualified Data.Utf8 as Utf8 - -import qualified AST.Canonical as Can -import qualified AST.Optimized as Opt -import qualified AST.Utils.Shader as Shader -import qualified Data.Index as Index -import qualified Elm.Compiler.Type as Type -import qualified Elm.Compiler.Type.Extract as Extract -import qualified Elm.Version as V -import qualified Elm.ModuleName as ModuleName -import qualified Elm.Package as Pkg -import qualified Generate.JavaScript.Builder as JS -import qualified Generate.JavaScript.Name as JsName -import qualified Generate.Mode as Mode -import qualified Json.Encode as Encode -import Json.Encode ((==>)) -import qualified Optimize.DecisionTree as DT -import qualified Reporting.Annotation as A - - - --- EXPRESSIONS - - -generateJsExpr :: Mode.Mode -> Opt.Expr -> JS.Expr -generateJsExpr mode expression = - codeToExpr (generate mode expression) - - -generate :: Mode.Mode -> Opt.Expr -> Code -generate mode expression = - case expression of - Opt.Bool bool -> - JsExpr $ JS.Bool bool - - Opt.Chr char -> - JsExpr $ - case mode of - Mode.Dev _ -> - JS.Call toChar [ JS.String (Utf8.toBuilder char) ] - - Mode.Prod _ -> - JS.String (Utf8.toBuilder char) - - Opt.Str string -> - JsExpr $ JS.String (Utf8.toBuilder string) - - Opt.Int int -> - JsExpr $ JS.Int int - - Opt.Float float -> - JsExpr $ JS.Float (Utf8.toBuilder float) - - Opt.VarLocal name -> - JsExpr $ JS.Ref (JsName.fromLocal name) - - Opt.VarGlobal (Opt.Global home name) -> - JsExpr $ JS.Ref (JsName.fromGlobal home name) - - Opt.VarEnum (Opt.Global home name) index -> - case mode of - Mode.Dev _ -> - JsExpr $ JS.Ref (JsName.fromGlobal home name) - - Mode.Prod _ -> - JsExpr $ JS.Int (Index.toMachine index) - - Opt.VarBox (Opt.Global home name) -> - JsExpr $ JS.Ref $ - case mode of - Mode.Dev _ -> JsName.fromGlobal home name - Mode.Prod _ -> JsName.fromGlobal ModuleName.basics Name.identity - - Opt.VarCycle home name -> - JsExpr $ JS.Call (JS.Ref (JsName.fromCycle home name)) [] - - Opt.VarDebug name home region unhandledValueName -> - JsExpr $ generateDebug name home region unhandledValueName - - Opt.VarKernel home name -> - JsExpr $ JS.Ref (JsName.fromKernel home name) - - Opt.List entries -> - case entries of - [] -> - JsExpr $ JS.Ref (JsName.fromKernel Name.list "Nil") - - _ -> - JsExpr $ - JS.Call - (JS.Ref (JsName.fromKernel Name.list "fromArray")) - [ JS.Array $ map (generateJsExpr mode) entries - ] - - Opt.Function args body -> - generateFunction (map JsName.fromLocal args) (generate mode body) - - Opt.Call func args -> - JsExpr $ generateCall mode func args - - Opt.TailCall name args -> - JsBlock $ generateTailCall mode name args - - Opt.If branches final -> - generateIf mode branches final - - Opt.Let def body -> - JsBlock $ - generateDef mode def : codeToStmtList (generate mode body) - - Opt.Destruct (Opt.Destructor name path) body -> - let - pathDef = JS.Var (JsName.fromLocal name) (generatePath mode path) - in - JsBlock $ pathDef : codeToStmtList (generate mode body) - - Opt.Case label root decider jumps -> - JsBlock $ generateCase mode label root decider jumps - - Opt.Accessor field -> - JsExpr $ JS.Function Nothing [JsName.dollar] - [ JS.Return $ - JS.Access (JS.Ref JsName.dollar) (generateField mode field) - ] - - Opt.Access record field -> - JsExpr $ JS.Access (generateJsExpr mode record) (generateField mode field) - - Opt.Update record fields -> - JsExpr $ - JS.Call (JS.Ref (JsName.fromKernel Name.utils "update")) - [ generateJsExpr mode record - , generateRecord mode fields - ] - - Opt.Record fields -> - JsExpr $ generateRecord mode fields - - Opt.Unit -> - case mode of - Mode.Dev _ -> - JsExpr $ JS.Ref (JsName.fromKernel Name.utils "Tuple0") - - Mode.Prod _ -> - JsExpr $ JS.Int 0 - - Opt.Tuple a b maybeC -> - JsExpr $ - case maybeC of - Nothing -> - JS.Call (JS.Ref (JsName.fromKernel Name.utils "Tuple2")) - [ generateJsExpr mode a - , generateJsExpr mode b - ] - - Just c -> - JS.Call (JS.Ref (JsName.fromKernel Name.utils "Tuple3")) - [ generateJsExpr mode a - , generateJsExpr mode b - , generateJsExpr mode c - ] - - Opt.Shader src attributes uniforms -> - let - toTranlation field = - ( JsName.fromLocal field - , JS.String (JsName.toBuilder (generateField mode field)) - ) - - toTranslationObject fields = - JS.Object (map toTranlation (Set.toList fields)) - in - JsExpr $ JS.Object $ - [ ( JsName.fromLocal "src", JS.String (Shader.toJsStringBuilder src) ) - , ( JsName.fromLocal "attributes", toTranslationObject attributes ) - , ( JsName.fromLocal "uniforms", toTranslationObject uniforms ) - ] - - - --- CODE CHUNKS - - -data Code - = JsExpr JS.Expr - | JsBlock [JS.Stmt] - - -codeToExpr :: Code -> JS.Expr -codeToExpr code = - case code of - JsExpr expr -> - expr - - JsBlock [ JS.Return expr ] -> - expr - - JsBlock stmts -> - JS.Call (JS.Function Nothing [] stmts) [] - - -codeToStmtList :: Code -> [JS.Stmt] -codeToStmtList code = - case code of - JsExpr (JS.Call (JS.Function Nothing [] stmts) []) -> - stmts - - JsExpr expr -> - [ JS.Return expr ] - - JsBlock stmts -> - stmts - - -codeToStmt :: Code -> JS.Stmt -codeToStmt code = - case code of - JsExpr (JS.Call (JS.Function Nothing [] stmts) []) -> - JS.Block stmts - - JsExpr expr -> - JS.Return expr - - JsBlock [stmt] -> - stmt - - JsBlock stmts -> - JS.Block stmts - - - --- CHARS - - -{-# NOINLINE toChar #-} -toChar :: JS.Expr -toChar = - JS.Ref (JsName.fromKernel Name.utils "chr") - - - --- CTOR - - -generateCtor :: Mode.Mode -> Opt.Global -> Index.ZeroBased -> Int -> Code -generateCtor mode (Opt.Global home name) index arity = - let - argNames = - Index.indexedMap (\i _ -> JsName.fromIndex i) [1 .. arity] - - ctorTag = - case mode of - Mode.Dev _ -> JS.String (Name.toBuilder name) - Mode.Prod _ -> JS.Int (ctorToInt home name index) - in - generateFunction argNames $ JsExpr $ JS.Object $ - (JsName.dollar, ctorTag) : map (\n -> (n, JS.Ref n)) argNames - - -ctorToInt :: ModuleName.Canonical -> Name.Name -> Index.ZeroBased -> Int -ctorToInt home name index = - if home == ModuleName.dict && name == "RBNode_elm_builtin" || name == "RBEmpty_elm_builtin" then - 0 - Index.toHuman index - else - Index.toMachine index - - - --- RECORDS - - -generateRecord :: Mode.Mode -> Map.Map Name.Name Opt.Expr -> JS.Expr -generateRecord mode fields = - let - toPair (field, value) = - (generateField mode field, generateJsExpr mode value) - in - JS.Object (map toPair (Map.toList fields)) - - -generateField :: Mode.Mode -> Name.Name -> JsName.Name -generateField mode name = - case mode of - Mode.Dev _ -> - JsName.fromLocal name - - Mode.Prod fields -> - fields ! name - - - - --- DEBUG - - -generateDebug :: Name.Name -> ModuleName.Canonical -> A.Region -> Maybe Name.Name -> JS.Expr -generateDebug name (ModuleName.Canonical _ home) region unhandledValueName = - if name /= "todo" then - JS.Ref (JsName.fromGlobal ModuleName.debug name) - else - case unhandledValueName of - Nothing -> - JS.Call (JS.Ref (JsName.fromKernel Name.debug "todo")) $ - [ JS.String (Name.toBuilder home) - , regionToJsExpr region - ] - - Just valueName -> - JS.Call (JS.Ref (JsName.fromKernel Name.debug "todoCase")) $ - [ JS.String (Name.toBuilder home) - , regionToJsExpr region - , JS.Ref (JsName.fromLocal valueName) - ] - - -regionToJsExpr :: A.Region -> JS.Expr -regionToJsExpr (A.Region start end) = - JS.Object - [ ( JsName.fromLocal "start", positionToJsExpr start ) - , ( JsName.fromLocal "end", positionToJsExpr end ) - ] - - -positionToJsExpr :: A.Position -> JS.Expr -positionToJsExpr (A.Position line column) = - JS.Object - [ ( JsName.fromLocal "line", JS.Int (fromIntegral line) ) - , ( JsName.fromLocal "column", JS.Int (fromIntegral column) ) - ] - - - --- FUNCTION - - -generateFunction :: [JsName.Name] -> Code -> Code -generateFunction args body = - case IntMap.lookup (length args) funcHelpers of - Just helper -> - JsExpr $ - JS.Call helper - [ JS.Function Nothing args $ - codeToStmtList body - ] - - Nothing -> - let - addArg arg code = - JsExpr $ JS.Function Nothing [arg] $ - codeToStmtList code - in - foldr addArg body args - - -{-# NOINLINE funcHelpers #-} -funcHelpers :: IntMap.IntMap JS.Expr -funcHelpers = - IntMap.fromList $ - map (\n -> (n, JS.Ref (JsName.makeF n))) [2..9] - - - --- CALLS - - -generateCall :: Mode.Mode -> Opt.Expr -> [Opt.Expr] -> JS.Expr -generateCall mode func args = - case func of - Opt.VarGlobal global@(Opt.Global (ModuleName.Canonical pkg _) _) | pkg == Pkg.core -> - generateCoreCall mode global args - - Opt.VarBox _ -> - case mode of - Mode.Dev _ -> - generateCallHelp mode func args - - Mode.Prod _ -> - case args of - [arg] -> - generateJsExpr mode arg - - _ -> - generateCallHelp mode func args - - _ -> - generateCallHelp mode func args - - -generateCallHelp :: Mode.Mode -> Opt.Expr -> [Opt.Expr] -> JS.Expr -generateCallHelp mode func args = - generateNormalCall - (generateJsExpr mode func) - (map (generateJsExpr mode) args) - - -generateGlobalCall :: ModuleName.Canonical -> Name.Name -> [JS.Expr] -> JS.Expr -generateGlobalCall home name args = - generateNormalCall (JS.Ref (JsName.fromGlobal home name)) args - - -generateNormalCall :: JS.Expr -> [JS.Expr] -> JS.Expr -generateNormalCall func args = - case IntMap.lookup (length args) callHelpers of - Just helper -> - JS.Call helper (func:args) - - Nothing -> - List.foldl' (\f a -> JS.Call f [a]) func args - - -{-# NOINLINE callHelpers #-} -callHelpers :: IntMap.IntMap JS.Expr -callHelpers = - IntMap.fromList $ - map (\n -> (n, JS.Ref (JsName.makeA n))) [2..9] - - - --- CORE CALLS - - -generateCoreCall :: Mode.Mode -> Opt.Global -> [Opt.Expr] -> JS.Expr -generateCoreCall mode (Opt.Global home@(ModuleName.Canonical _ moduleName) name) args = - if moduleName == Name.basics then - generateBasicsCall mode home name args - - else if moduleName == Name.bitwise then - generateBitwiseCall home name (map (generateJsExpr mode) args) - - else if moduleName == Name.tuple then - generateTupleCall home name (map (generateJsExpr mode) args) - - else if moduleName == Name.jsArray then - generateJsArrayCall home name (map (generateJsExpr mode) args) - - else - generateGlobalCall home name (map (generateJsExpr mode) args) - - -generateTupleCall :: ModuleName.Canonical -> Name.Name -> [JS.Expr] -> JS.Expr -generateTupleCall home name args = - case args of - [value] -> - case name of - "first" -> JS.Access value (JsName.fromLocal "a") - "second" -> JS.Access value (JsName.fromLocal "b") - _ -> generateGlobalCall home name args - - _ -> - generateGlobalCall home name args - - -generateJsArrayCall :: ModuleName.Canonical -> Name.Name -> [JS.Expr] -> JS.Expr -generateJsArrayCall home name args = - case args of - [entry] | name == "singleton" -> JS.Array [entry] - [index, array] | name == "unsafeGet" -> JS.Index array index - _ -> generateGlobalCall home name args - - -generateBitwiseCall :: ModuleName.Canonical -> Name.Name -> [JS.Expr] -> JS.Expr -generateBitwiseCall home name args = - case args of - [arg] -> - case name of - "complement" -> JS.Prefix JS.PrefixComplement arg - _ -> generateGlobalCall home name args - - [left,right] -> - case name of - "and" -> JS.Infix JS.OpBitwiseAnd left right - "or" -> JS.Infix JS.OpBitwiseOr left right - "xor" -> JS.Infix JS.OpBitwiseXor left right - "shiftLeftBy" -> JS.Infix JS.OpLShift right left - "shiftRightBy" -> JS.Infix JS.OpSpRShift right left - "shiftRightZfBy" -> JS.Infix JS.OpZfRShift right left - _ -> generateGlobalCall home name args - - _ -> - generateGlobalCall home name args - - -generateBasicsCall :: Mode.Mode -> ModuleName.Canonical -> Name.Name -> [Opt.Expr] -> JS.Expr -generateBasicsCall mode home name args = - case args of - [elmArg] -> - let arg = generateJsExpr mode elmArg in - case name of - "not" -> JS.Prefix JS.PrefixNot arg - "negate" -> JS.Prefix JS.PrefixNegate arg - "toFloat" -> arg - "truncate" -> JS.Infix JS.OpBitwiseOr arg (JS.Int 0) - _ -> generateGlobalCall home name [arg] - - [elmLeft, elmRight] -> - case name of - -- NOTE: removed "composeL" and "composeR" because of this issue: - -- https://github.com/elm/compiler/issues/1722 - "append" -> append mode elmLeft elmRight - "apL" -> generateJsExpr mode $ apply elmLeft elmRight - "apR" -> generateJsExpr mode $ apply elmRight elmLeft - _ -> - let - left = generateJsExpr mode elmLeft - right = generateJsExpr mode elmRight - in - case name of - "add" -> JS.Infix JS.OpAdd left right - "sub" -> JS.Infix JS.OpSub left right - "mul" -> JS.Infix JS.OpMul left right - "fdiv" -> JS.Infix JS.OpDiv left right - "idiv" -> JS.Infix JS.OpBitwiseOr (JS.Infix JS.OpDiv left right) (JS.Int 0) - "eq" -> equal left right - "neq" -> notEqual left right - "lt" -> cmp JS.OpLt JS.OpLt 0 left right - "gt" -> cmp JS.OpGt JS.OpGt 0 left right - "le" -> cmp JS.OpLe JS.OpLt 1 left right - "ge" -> cmp JS.OpGe JS.OpGt (-1) left right - "or" -> JS.Infix JS.OpOr left right - "and" -> JS.Infix JS.OpAnd left right - "xor" -> JS.Infix JS.OpNe left right - "remainderBy" -> JS.Infix JS.OpMod right left - _ -> generateGlobalCall home name [left, right] - - _ -> - generateGlobalCall home name (map (generateJsExpr mode) args) - - -equal :: JS.Expr -> JS.Expr -> JS.Expr -equal left right = - if isLiteral left || isLiteral right then - strictEq left right - else - JS.Call (JS.Ref (JsName.fromKernel Name.utils "eq")) [left, right] - - -notEqual :: JS.Expr -> JS.Expr -> JS.Expr -notEqual left right = - if isLiteral left || isLiteral right then - strictNEq left right - else - JS.Prefix JS.PrefixNot $ - JS.Call (JS.Ref (JsName.fromKernel Name.utils "eq")) [left, right] - - -cmp :: JS.InfixOp -> JS.InfixOp -> Int -> JS.Expr -> JS.Expr -> JS.Expr -cmp idealOp backupOp backupInt left right = - if isLiteral left || isLiteral right then - JS.Infix idealOp left right - else - JS.Infix backupOp - (JS.Call (JS.Ref (JsName.fromKernel Name.utils "cmp")) [left, right]) - (JS.Int backupInt) - - -isLiteral :: JS.Expr -> Bool -isLiteral expr = - case expr of - JS.String _ -> - True - - JS.Float _ -> - True - - JS.Int _ -> - True - - JS.Bool _ -> - True - - _ -> - False - - -apply :: Opt.Expr -> Opt.Expr -> Opt.Expr -apply func value = - case func of - Opt.Accessor field -> - Opt.Access value field - - Opt.Call f args -> - Opt.Call f (args ++ [value]) - - _ -> - Opt.Call func [value] - - -append :: Mode.Mode -> Opt.Expr -> Opt.Expr -> JS.Expr -append mode left right = - let seqs = generateJsExpr mode left : toSeqs mode right in - if any isStringLiteral seqs then - foldr1 (JS.Infix JS.OpAdd) seqs - else - foldr1 jsAppend seqs - - -jsAppend :: JS.Expr -> JS.Expr -> JS.Expr -jsAppend a b = - JS.Call (JS.Ref (JsName.fromKernel Name.utils "ap")) [a, b] - - -toSeqs :: Mode.Mode -> Opt.Expr -> [JS.Expr] -toSeqs mode expr = - case expr of - Opt.Call (Opt.VarGlobal (Opt.Global home "append")) [left, right] - | home == ModuleName.basics -> - generateJsExpr mode left : toSeqs mode right - - _ -> - [generateJsExpr mode expr] - - -isStringLiteral :: JS.Expr -> Bool -isStringLiteral expr = - case expr of - JS.String _ -> - True - - _ -> - False - - - --- SIMPLIFY INFIX OPERATORS - - -strictEq :: JS.Expr -> JS.Expr -> JS.Expr -strictEq left right = - case left of - JS.Int 0 -> - JS.Prefix JS.PrefixNot right - - JS.Bool bool -> - if bool then right else JS.Prefix JS.PrefixNot right - - _ -> - case right of - JS.Int 0 -> - JS.Prefix JS.PrefixNot left - - JS.Bool bool -> - if bool then left else JS.Prefix JS.PrefixNot left - - _ -> - JS.Infix JS.OpEq left right - - -strictNEq :: JS.Expr -> JS.Expr -> JS.Expr -strictNEq left right = - case left of - JS.Int 0 -> - JS.Prefix JS.PrefixNot (JS.Prefix JS.PrefixNot right) - - JS.Bool bool -> - if bool then JS.Prefix JS.PrefixNot right else right - - _ -> - case right of - JS.Int 0 -> - JS.Prefix JS.PrefixNot (JS.Prefix JS.PrefixNot left) - - JS.Bool bool -> - if bool then JS.Prefix JS.PrefixNot left else left - - _ -> - JS.Infix JS.OpNe left right - - - --- TAIL CALL - - --- TODO check if JS minifiers collapse unnecessary temporary variables --- -generateTailCall :: Mode.Mode -> Name.Name -> [(Name.Name, Opt.Expr)] -> [JS.Stmt] -generateTailCall mode name args = - let - toTempVars (argName, arg) = - ( JsName.makeTemp argName, generateJsExpr mode arg ) - - toRealVars (argName, _) = - JS.ExprStmt $ - JS.Assign (JS.LRef (JsName.fromLocal argName)) (JS.Ref (JsName.makeTemp argName)) - in - JS.Vars (map toTempVars args) - : map toRealVars args - ++ [ JS.Continue (Just (JsName.fromLocal name)) ] - - - --- DEFINITIONS - - -generateDef :: Mode.Mode -> Opt.Def -> JS.Stmt -generateDef mode def = - case def of - Opt.Def name body -> - JS.Var (JsName.fromLocal name) (generateJsExpr mode body) - - Opt.TailDef name argNames body -> - JS.Var (JsName.fromLocal name) (codeToExpr (generateTailDef mode name argNames body)) - - -generateTailDef :: Mode.Mode -> Name.Name -> [Name.Name] -> Opt.Expr -> Code -generateTailDef mode name argNames body = - generateFunction (map JsName.fromLocal argNames) $ JsBlock $ - [ JS.Labelled (JsName.fromLocal name) $ - JS.While (JS.Bool True) $ - codeToStmt $ generate mode body - ] - - - --- PATHS - - -generatePath :: Mode.Mode -> Opt.Path -> JS.Expr -generatePath mode path = - case path of - Opt.Index index subPath -> - JS.Access (generatePath mode subPath) (JsName.fromIndex index) - - Opt.Root name -> - JS.Ref (JsName.fromLocal name) - - Opt.Field field subPath -> - JS.Access (generatePath mode subPath) (generateField mode field) - - Opt.Unbox subPath -> - case mode of - Mode.Dev _ -> - JS.Access (generatePath mode subPath) (JsName.fromIndex Index.first) - - Mode.Prod _ -> - generatePath mode subPath - - - --- GENERATE IFS - - -generateIf :: Mode.Mode -> [(Opt.Expr, Opt.Expr)] -> Opt.Expr -> Code -generateIf mode givenBranches givenFinal = - let - (branches, final) = - crushIfs givenBranches givenFinal - - convertBranch (condition, expr) = - ( generateJsExpr mode condition - , generate mode expr - ) - - branchExprs = map convertBranch branches - finalCode = generate mode final - in - if isBlock finalCode || any (isBlock . snd) branchExprs then - JsBlock [ foldr addStmtIf (codeToStmt finalCode) branchExprs ] - else - JsExpr $ foldr addExprIf (codeToExpr finalCode) branchExprs - - -addExprIf :: (JS.Expr, Code) -> JS.Expr -> JS.Expr -addExprIf (condition, branch) final = - JS.If condition (codeToExpr branch) final - - -addStmtIf :: (JS.Expr, Code) -> JS.Stmt -> JS.Stmt -addStmtIf (condition, branch) final = - JS.IfStmt condition (codeToStmt branch) final - - -isBlock :: Code -> Bool -isBlock code = - case code of - JsBlock _ -> True - JsExpr _ -> False - - -crushIfs :: [(Opt.Expr, Opt.Expr)] -> Opt.Expr -> ([(Opt.Expr, Opt.Expr)], Opt.Expr) -crushIfs branches final = - crushIfsHelp [] branches final - - -crushIfsHelp - :: [(Opt.Expr, Opt.Expr)] - -> [(Opt.Expr, Opt.Expr)] - -> Opt.Expr - -> ([(Opt.Expr, Opt.Expr)], Opt.Expr) -crushIfsHelp visitedBranches unvisitedBranches final = - case unvisitedBranches of - [] -> - case final of - Opt.If subBranches subFinal -> - crushIfsHelp visitedBranches subBranches subFinal - - _ -> - (reverse visitedBranches, final) - - visiting : unvisited -> - crushIfsHelp (visiting : visitedBranches) unvisited final - - - --- CASE EXPRESSIONS - - -generateCase :: Mode.Mode -> Name.Name -> Name.Name -> Opt.Decider Opt.Choice -> [(Int, Opt.Expr)] -> [JS.Stmt] -generateCase mode label root decider jumps = - foldr (goto mode label) (generateDecider mode label root decider) jumps - - -goto :: Mode.Mode -> Name.Name -> (Int, Opt.Expr) -> [JS.Stmt] -> [JS.Stmt] -goto mode label (index, branch) stmts = - let - labeledDeciderStmt = - JS.Labelled - (JsName.makeLabel label index) - (JS.While (JS.Bool True) (JS.Block stmts)) - in - labeledDeciderStmt : codeToStmtList (generate mode branch) - - -generateDecider :: Mode.Mode -> Name.Name -> Name.Name -> Opt.Decider Opt.Choice -> [JS.Stmt] -generateDecider mode label root decisionTree = - case decisionTree of - Opt.Leaf (Opt.Inline branch) -> - codeToStmtList (generate mode branch) - - Opt.Leaf (Opt.Jump index) -> - [ JS.Break (Just (JsName.makeLabel label index)) ] - - Opt.Chain testChain success failure -> - [ JS.IfStmt - (List.foldl1' (JS.Infix JS.OpAnd) (map (generateIfTest mode root) testChain)) - (JS.Block $ generateDecider mode label root success) - (JS.Block $ generateDecider mode label root failure) - ] - - Opt.FanOut path edges fallback -> - [ JS.Switch - (generateCaseTest mode root path (fst (head edges))) - ( foldr - (\edge cases -> generateCaseBranch mode label root edge : cases) - [ JS.Default (generateDecider mode label root fallback) ] - edges - ) - ] - - -generateIfTest :: Mode.Mode -> Name.Name -> (DT.Path, DT.Test) -> JS.Expr -generateIfTest mode root (path, test) = - let - value = pathToJsExpr mode root path - in - case test of - DT.IsCtor home name index _ opts -> - let - tag = - case mode of - Mode.Dev _ -> JS.Access value JsName.dollar - Mode.Prod _ -> - case opts of - Can.Normal -> JS.Access value JsName.dollar - Can.Enum -> value - Can.Unbox -> value - in - strictEq tag $ - case mode of - Mode.Dev _ -> JS.String (Name.toBuilder name) - Mode.Prod _ -> JS.Int (ctorToInt home name index) - - DT.IsBool True -> - value - - DT.IsBool False -> - JS.Prefix JS.PrefixNot value - - DT.IsInt int -> - strictEq value (JS.Int int) - - DT.IsChr char -> - strictEq (JS.String (Utf8.toBuilder char)) $ - case mode of - Mode.Dev _ -> JS.Call (JS.Access value (JsName.fromLocal "valueOf")) [] - Mode.Prod _ -> value - - DT.IsStr string -> - strictEq value (JS.String (Utf8.toBuilder string)) - - DT.IsCons -> - JS.Access value (JsName.fromLocal "b") - - DT.IsNil -> - JS.Prefix JS.PrefixNot $ - JS.Access value (JsName.fromLocal "b") - - DT.IsTuple -> - error "COMPILER BUG - there should never be tests on a tuple" - - - -generateCaseBranch :: Mode.Mode -> Name.Name -> Name.Name -> (DT.Test, Opt.Decider Opt.Choice) -> JS.Case -generateCaseBranch mode label root (test, subTree) = - JS.Case - (generateCaseValue mode test) - (generateDecider mode label root subTree) - - -generateCaseValue :: Mode.Mode -> DT.Test -> JS.Expr -generateCaseValue mode test = - case test of - DT.IsCtor home name index _ _ -> - case mode of - Mode.Dev _ -> JS.String (Name.toBuilder name) - Mode.Prod _ -> JS.Int (ctorToInt home name index) - - DT.IsInt int -> - JS.Int int - - DT.IsChr char -> - JS.String (Utf8.toBuilder char) - - DT.IsStr string -> - JS.String (Utf8.toBuilder string) - - DT.IsBool _ -> - error "COMPILER BUG - there should never be three tests on a boolean" - - DT.IsCons -> - error "COMPILER BUG - there should never be three tests on a list" - - DT.IsNil -> - error "COMPILER BUG - there should never be three tests on a list" - - DT.IsTuple -> - error "COMPILER BUG - there should never be three tests on a tuple" - - -generateCaseTest :: Mode.Mode -> Name.Name -> DT.Path -> DT.Test -> JS.Expr -generateCaseTest mode root path exampleTest = - let - value = pathToJsExpr mode root path - in - case exampleTest of - DT.IsCtor home name _ _ opts -> - if name == Name.bool && home == ModuleName.basics then - value - else - case mode of - Mode.Dev _ -> - JS.Access value JsName.dollar - - Mode.Prod _ -> - case opts of - Can.Normal -> - JS.Access value JsName.dollar - - Can.Enum -> - value - - Can.Unbox -> - value - - DT.IsInt _ -> - value - - DT.IsStr _ -> - value - - DT.IsChr _ -> - case mode of - Mode.Dev _ -> - JS.Call (JS.Access value (JsName.fromLocal "valueOf")) [] - - Mode.Prod _ -> - value - - DT.IsBool _ -> - error "COMPILER BUG - there should never be three tests on a list" - - DT.IsCons -> - error "COMPILER BUG - there should never be three tests on a list" - - DT.IsNil -> - error "COMPILER BUG - there should never be three tests on a list" - - DT.IsTuple -> - error "COMPILER BUG - there should never be three tests on a list" - - - --- PATTERN PATHS - - -pathToJsExpr :: Mode.Mode -> Name.Name -> DT.Path -> JS.Expr -pathToJsExpr mode root path = - case path of - DT.Index index subPath -> - JS.Access (pathToJsExpr mode root subPath) (JsName.fromIndex index) - - DT.Unbox subPath -> - case mode of - Mode.Dev _ -> - JS.Access (pathToJsExpr mode root subPath) (JsName.fromIndex Index.first) - - Mode.Prod _ -> - pathToJsExpr mode root subPath - - DT.Empty -> - JS.Ref (JsName.fromLocal root) - - - --- GENERATE MAIN - - -generateMain :: Mode.Mode -> ModuleName.Canonical -> Opt.Main -> JS.Expr -generateMain mode home main = - case main of - Opt.Static -> - JS.Ref (JsName.fromKernel Name.virtualDom "init") - # JS.Ref (JsName.fromGlobal home "main") - # JS.Int 0 - # JS.Int 0 - - Opt.Dynamic msgType decoder -> - JS.Ref (JsName.fromGlobal home "main") - # generateJsExpr mode decoder - # toDebugMetadata mode msgType - - -(#) :: JS.Expr -> JS.Expr -> JS.Expr -(#) func arg = - JS.Call func [arg] - - -toDebugMetadata :: Mode.Mode -> Can.Type -> JS.Expr -toDebugMetadata mode msgType = - case mode of - Mode.Prod _ -> - JS.Int 0 - - Mode.Dev Nothing -> - JS.Int 0 - - Mode.Dev (Just interfaces) -> - JS.Json $ Encode.object $ - [ "versions" ==> Encode.object [ "elm" ==> V.encode V.compiler ] - , "types" ==> Type.encodeMetadata (Extract.fromMsg interfaces msgType) - ] diff --git a/compiler/src/Generate/JavaScript/Name.hs b/compiler/src/Generate/JavaScript/Name.hs deleted file mode 100644 index 3d857bc1fb..0000000000 --- a/compiler/src/Generate/JavaScript/Name.hs +++ /dev/null @@ -1,261 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE OverloadedStrings #-} -module Generate.JavaScript.Name - ( Name - , toBuilder - , fromIndex - , fromInt - , fromLocal - , fromGlobal - , fromCycle - , fromKernel - , makeF - , makeA - , makeLabel - , makeTemp - , dollar - ) - where - - -import qualified Data.ByteString.Builder as B -import Data.Monoid ((<>)) -import qualified Data.Map as Map -import qualified Data.Name as Name -import qualified Data.Set as Set -import qualified Data.Utf8 as Utf8 -import Data.Word (Word8) - -import qualified Data.Index as Index -import qualified Elm.ModuleName as ModuleName -import qualified Elm.Package as Pkg - - - --- NAME - - -newtype Name = - Name { toBuilder :: B.Builder } - - - --- CONSTRUCTORS - - -fromIndex :: Index.ZeroBased -> Name -fromIndex index = - fromInt (Index.toMachine index) - - -fromInt :: Int -> Name -fromInt n = - Name (Name.toBuilder (intToAscii n)) - - -fromLocal :: Name.Name -> Name -fromLocal name = - if Set.member name reservedNames then - Name ("_" <> Name.toBuilder name) - else - Name (Name.toBuilder name) - - -fromGlobal :: ModuleName.Canonical -> Name.Name -> Name -fromGlobal home name = - Name $ homeToBuilder home <> usd <> Name.toBuilder name - - -fromCycle :: ModuleName.Canonical -> Name.Name -> Name -fromCycle home name = - Name $ homeToBuilder home <> "$cyclic$" <> Name.toBuilder name - - -fromKernel :: Name.Name -> Name.Name -> Name -fromKernel home name = - Name ("_" <> Name.toBuilder home <> "_" <> Name.toBuilder name) - - -{-# INLINE homeToBuilder #-} -homeToBuilder :: ModuleName.Canonical -> B.Builder -homeToBuilder (ModuleName.Canonical (Pkg.Name author project) home) = - usd <> - Utf8.toEscapedBuilder 0x2D {- - -} 0x5F {- _ -} author - <> usd <> - Utf8.toEscapedBuilder 0x2D {- - -} 0x5F {- _ -} project - <> usd <> - Utf8.toEscapedBuilder 0x2E {- . -} 0x24 {- $ -} home - - - --- TEMPORARY NAMES - - -makeF :: Int -> Name -makeF n = - Name ("F" <> B.intDec n) - - -makeA :: Int -> Name -makeA n = - Name ("A" <> B.intDec n) - - -makeLabel :: Name.Name -> Int -> Name -makeLabel name index = - Name (Name.toBuilder name <> usd <> B.intDec index) - - -makeTemp :: Name.Name -> Name -makeTemp name = - Name ("$temp$" <> Name.toBuilder name) - - -dollar :: Name -dollar = - Name usd - - -usd :: B.Builder -usd = - Name.toBuilder Name.dollar - - - --- RESERVED NAMES - - -{-# NOINLINE reservedNames #-} -reservedNames :: Set.Set Name.Name -reservedNames = - Set.union jsReservedWords elmReservedWords - - -jsReservedWords :: Set.Set Name.Name -jsReservedWords = - Set.fromList - [ "do", "if", "in" - , "NaN", "int", "for", "new", "try", "var", "let" - , "null", "true", "eval", "byte", "char", "goto", "long", "case", "else", "this", "void", "with", "enum" - , "false", "final", "float", "short", "break", "catch", "throw", "while", "class", "const", "super", "yield" - , "double", "native", "throws", "delete", "return", "switch", "typeof", "export", "import", "public", "static" - , "boolean", "default", "finally", "extends", "package", "private" - , "Infinity", "abstract", "volatile", "function", "continue", "debugger", "function" - , "undefined", "arguments", "transient", "interface", "protected" - , "instanceof", "implements" - , "synchronized" - ] - - -elmReservedWords :: Set.Set Name.Name -elmReservedWords = - Set.fromList - [ "F2", "F3", "F4", "F5", "F6", "F7", "F8", "F9" - , "A2", "A3", "A4", "A5", "A6", "A7", "A8", "A9" - ] - - - --- INT TO ASCII - - -intToAscii :: Int -> Name.Name -intToAscii n = - if n < 53 then -- skip $ as a standalone name - Name.fromWords [toByte n] - - else - intToAsciiHelp 2 (numStartBytes * numInnerBytes) allBadFields (n - 53) - - -intToAsciiHelp :: Int -> Int -> [BadFields] -> Int -> Name.Name -intToAsciiHelp width blockSize badFields n = - case badFields of - [] -> - if n < blockSize then - unsafeIntToAscii width [] n - else - intToAsciiHelp (width + 1) (blockSize * numInnerBytes) [] (n - blockSize) - - BadFields renamings : biggerBadFields -> - let availableSize = blockSize - Map.size renamings in - if n < availableSize then - let name = unsafeIntToAscii width [] n in - Map.findWithDefault name name renamings - else - intToAsciiHelp (width + 1) (blockSize * numInnerBytes) biggerBadFields (n - availableSize) - - - --- UNSAFE INT TO ASCII - - -unsafeIntToAscii :: Int -> [Word8] -> Int -> Name.Name -unsafeIntToAscii width bytes n = - if width <= 1 then - Name.fromWords (toByte n : bytes) - else - let - (quotient, remainder) = - quotRem n numInnerBytes - in - unsafeIntToAscii (width - 1) (toByte remainder : bytes) quotient - - - --- ASCII BYTES - - -numStartBytes :: Int -numStartBytes = - 54 - - -numInnerBytes :: Int -numInnerBytes = - 64 - - -toByte :: Int -> Word8 -toByte n - | n < 26 = fromIntegral (97 + n ) {- lower -} - | n < 52 = fromIntegral (65 + n - 26) {- upper -} - | n == 52 = 95 {- _ -} - | n == 53 = 36 {- $ -} - | n < 64 = fromIntegral (48 + n - 54) {- digit -} - | True = error $ "cannot convert int " ++ show n ++ " to ASCII" - - - --- BAD FIELDS - - -newtype BadFields = - BadFields { _renamings :: Renamings } - - -type Renamings = - Map.Map Name.Name Name.Name - - -allBadFields :: [BadFields] -allBadFields = - let - add keyword dict = - Map.alter (Just . addRenaming keyword) (Utf8.size keyword) dict - in - Map.elems $ Set.foldr add Map.empty jsReservedWords - - -addRenaming :: Name.Name -> Maybe BadFields -> BadFields -addRenaming keyword maybeBadFields = - let - width = Utf8.size keyword - maxName = numStartBytes * numInnerBytes ^ (width - 1) - 1 - in - case maybeBadFields of - Nothing -> - BadFields $ Map.singleton keyword (unsafeIntToAscii width [] maxName) - - Just (BadFields renamings) -> - BadFields $ Map.insert keyword (unsafeIntToAscii width [] (maxName - Map.size renamings)) renamings diff --git a/compiler/src/Generate/Mode.hs b/compiler/src/Generate/Mode.hs deleted file mode 100644 index 18b879e291..0000000000 --- a/compiler/src/Generate/Mode.hs +++ /dev/null @@ -1,63 +0,0 @@ -module Generate.Mode - ( Mode(..) - , isDebug - , ShortFieldNames - , shortenFieldNames - ) - where - - -import qualified Data.List as List -import qualified Data.Map as Map -import qualified Data.Maybe as Maybe -import qualified Data.Name as Name - -import qualified AST.Optimized as Opt -import qualified Elm.Compiler.Type.Extract as Extract -import qualified Generate.JavaScript.Name as JsName - - - --- MODE - - -data Mode - = Dev (Maybe Extract.Types) - | Prod ShortFieldNames - - -isDebug :: Mode -> Bool -isDebug mode = - case mode of - Dev mi -> Maybe.isJust mi - Prod _ -> False - - - --- SHORTEN FIELD NAMES - - -type ShortFieldNames = - Map.Map Name.Name JsName.Name - - -shortenFieldNames :: Opt.GlobalGraph -> ShortFieldNames -shortenFieldNames (Opt.GlobalGraph _ frequencies) = - Map.foldr addToShortNames Map.empty $ - Map.foldrWithKey addToBuckets Map.empty frequencies - - -addToBuckets :: Name.Name -> Int -> Map.Map Int [Name.Name] -> Map.Map Int [Name.Name] -addToBuckets field frequency buckets = - Map.insertWith (++) frequency [field] buckets - - -addToShortNames :: [Name.Name] -> ShortFieldNames -> ShortFieldNames -addToShortNames fields shortNames = - List.foldl' addField shortNames fields - - -addField :: ShortFieldNames -> Name.Name -> ShortFieldNames -addField shortNames field = - let rename = JsName.fromInt (Map.size shortNames) in - Map.insert field rename shortNames diff --git a/compiler/src/Json/Decode.hs b/compiler/src/Json/Decode.hs deleted file mode 100644 index 2f432e9bf2..0000000000 --- a/compiler/src/Json/Decode.hs +++ /dev/null @@ -1,799 +0,0 @@ -{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind -fno-warn-name-shadowing #-} -{-# LANGUAGE BangPatterns, Rank2Types, OverloadedStrings, UnboxedTuples #-} -module Json.Decode - ( fromByteString - , Decoder - , string - , customString - , bool - , int - , list - , nonEmptyList - , pair - -- - , KeyDecoder(..) - , dict - , pairs - , field - -- - , oneOf - , failure - , mapError - -- - , Error(..) - , Problem(..) - , DecodeExpectation(..) - , ParseError(..) - , StringProblem(..) - ) - where - - -import qualified Data.ByteString.Internal as B -import qualified Data.Map as Map -import qualified Data.NonEmptyList as NE -import Data.Word (Word8) -import Foreign.Ptr (Ptr, plusPtr, minusPtr) -import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr) - -import qualified Json.String as Json -import qualified Parse.Keyword as K -import qualified Parse.Primitives as P -import Parse.Primitives (Row, Col) -import qualified Reporting.Annotation as A - - - --- RUNNERS - - -fromByteString :: Decoder x a -> B.ByteString -> Either (Error x) a -fromByteString (Decoder decode) src = - case P.fromByteString pFile BadEnd src of - Right ast -> - decode ast Right (Left . DecodeProblem src) - - Left problem -> - Left (ParseProblem src problem) - - - --- DECODERS - - -newtype Decoder x a = - Decoder - ( - forall b. - AST - -> (a -> b) - -> (Problem x -> b) - -> b - ) - - - --- ERRORS - - -data Error x - = DecodeProblem B.ByteString (Problem x) - | ParseProblem B.ByteString ParseError - - - --- DECODE PROBLEMS - - -data Problem x - = Field B.ByteString (Problem x) - | Index Int (Problem x) - | OneOf (Problem x) [Problem x] - | Failure A.Region x - | Expecting A.Region DecodeExpectation - - -data DecodeExpectation - = TObject - | TArray - | TString - | TBool - | TInt - | TObjectWith B.ByteString - | TArrayPair Int - - - --- INSTANCES - - -instance Functor (Decoder x) where - {-# INLINE fmap #-} - fmap func (Decoder decodeA) = - Decoder $ \ast ok err -> - let - ok' a = ok (func a) - in - decodeA ast ok' err - - -instance Applicative (Decoder x) where - {-# INLINE pure #-} - pure = return - - {-# INLINE (<*>) #-} - (<*>) (Decoder decodeFunc) (Decoder decodeArg) = - Decoder $ \ast ok err -> - let - okF func = - let - okA arg = ok (func arg) - in - decodeArg ast okA err - in - decodeFunc ast okF err - - -instance Monad (Decoder x) where - {-# INLINE return #-} - return a = - Decoder $ \_ ok _ -> - ok a - - {-# INLINE (>>=) #-} - (>>=) (Decoder decodeA) callback = - Decoder $ \ast ok err -> - let - ok' a = - case callback a of - Decoder decodeB -> decodeB ast ok err - in - decodeA ast ok' err - - - --- STRINGS - - -string :: Decoder x Json.String -string = - Decoder $ \(A.At region ast) ok err -> - case ast of - String snippet -> - ok (Json.fromSnippet snippet) - - _ -> - err (Expecting region TString) - - -customString :: P.Parser x a -> (Row -> Col -> x) -> Decoder x a -customString parser toBadEnd = - Decoder $ \(A.At region ast) ok err -> - case ast of - String snippet -> - case P.fromSnippet parser toBadEnd snippet of - Right a -> ok a - Left x -> err (Failure region x) - - _ -> - err (Expecting region TString) - - - --- BOOL - - -bool :: Decoder x Bool -bool = - Decoder $ \(A.At region ast) ok err -> - case ast of - TRUE -> - ok True - - FALSE -> - ok False - - _ -> - err (Expecting region TBool) - - - --- INT - - -int :: Decoder x Int -int = - Decoder $ \(A.At region ast) ok err -> - case ast of - Int n -> - ok n - - _ -> - err (Expecting region TInt) - - - --- LISTS - - -list :: Decoder x a -> Decoder x [a] -list decoder = - Decoder $ \(A.At region ast) ok err -> - case ast of - Array asts -> - listHelp decoder ok err 0 asts [] - - _ -> - err (Expecting region TArray) - - -listHelp :: Decoder x a -> ([a] -> b) -> (Problem x -> b) -> Int -> [AST] -> [a] -> b -listHelp decoder@(Decoder decodeA) ok err !i asts revs = - case asts of - [] -> - ok (reverse revs) - - ast:asts -> - let - ok' value = listHelp decoder ok err (i+1) asts (value:revs) - err' prob = err (Index i prob) - in - decodeA ast ok' err' - - - --- NON-EMPTY LISTS - - -nonEmptyList :: Decoder x a -> x -> Decoder x (NE.List a) -nonEmptyList decoder x = - do values <- list decoder - case values of - v:vs -> return (NE.List v vs) - [] -> failure x - - - --- PAIR - - -pair :: Decoder x a -> Decoder x b -> Decoder x (a,b) -pair (Decoder decodeA) (Decoder decodeB) = - Decoder $ \(A.At region ast) ok err -> - case ast of - Array vs -> - case vs of - [astA,astB] -> - let - err0 e = err (Index 0 e) - ok0 a = - let - err1 e = err (Index 1 e) - ok1 b = ok (a,b) - in - decodeB astB ok1 err1 - in - decodeA astA ok0 err0 - - _ -> - err (Expecting region (TArrayPair (length vs))) - - _ -> - err (Expecting region TArray) - - - --- OBJECTS - - -data KeyDecoder x a = - KeyDecoder (P.Parser x a) (Row -> Col -> x) - - -dict :: (Ord k) => KeyDecoder x k -> Decoder x a -> Decoder x (Map.Map k a) -dict keyDecoder valueDecoder = - Map.fromList <$> pairs keyDecoder valueDecoder - - -pairs :: KeyDecoder x k -> Decoder x a -> Decoder x [(k, a)] -pairs keyDecoder valueDecoder = - Decoder $ \(A.At region ast) ok err -> - case ast of - Object kvs -> - pairsHelp keyDecoder valueDecoder ok err kvs [] - - _ -> - err (Expecting region TObject) - - -pairsHelp :: KeyDecoder x k -> Decoder x a -> ([(k, a)] -> b) -> (Problem x -> b) -> [(P.Snippet, AST)] -> [(k, a)] -> b -pairsHelp keyDecoder@(KeyDecoder keyParser toBadEnd) valueDecoder@(Decoder decodeA) ok err kvs revs = - case kvs of - [] -> - ok (reverse revs) - - (snippet, ast) : kvs -> - case P.fromSnippet keyParser toBadEnd snippet of - Left x -> - err (Failure (snippetToRegion snippet) x) - - Right key -> - let - ok' value = pairsHelp keyDecoder valueDecoder ok err kvs ((key,value):revs) - err' prob = - let (P.Snippet fptr off len _ _) = snippet in - err (Field (B.PS fptr off len) prob) - in - decodeA ast ok' err' - - -snippetToRegion :: P.Snippet -> A.Region -snippetToRegion (P.Snippet _ _ len row col) = - A.Region (A.Position row col) (A.Position row (col + fromIntegral len)) - - - --- FIELDS - - -field :: B.ByteString -> Decoder x a -> Decoder x a -field key (Decoder decodeA) = - Decoder $ \(A.At region ast) ok err -> - case ast of - Object kvs -> - case findField key kvs of - Just value -> - let - err' prob = - err (Field key prob) - in - decodeA value ok err' - - Nothing -> - err (Expecting region (TObjectWith key)) - - _ -> - err (Expecting region TObject) - - -findField :: B.ByteString -> [(P.Snippet, AST)] -> Maybe AST -findField key pairs = - case pairs of - [] -> - Nothing - - (P.Snippet fptr off len _ _, value) : remainingPairs -> - if key == B.PS fptr off len - then Just value - else findField key remainingPairs - - - --- ONE OF - - -oneOf :: [Decoder x a] -> Decoder x a -oneOf decoders = - Decoder $ \ast ok err -> - case decoders of - Decoder decodeA : decoders -> - let - err' e = - oneOfHelp ast ok err decoders e [] - in - decodeA ast ok err' - - [] -> - error "Ran into (Json.Decode.oneOf [])" - - -oneOfHelp :: AST -> (a -> b) -> (Problem x -> b) -> [Decoder x a] -> Problem x -> [Problem x] -> b -oneOfHelp ast ok err decoders p ps = - case decoders of - Decoder decodeA : decoders -> - let - err' p' = - oneOfHelp ast ok err decoders p' (p:ps) - in - decodeA ast ok err' - - [] -> - err (oneOfError [] p ps) - - -oneOfError :: [Problem x] -> Problem x -> [Problem x] -> Problem x -oneOfError problems prob ps = - case ps of - [] -> - OneOf prob problems - - p:ps -> - oneOfError (prob:problems) p ps - - - --- FAILURE - - -failure :: x -> Decoder x a -failure x = - Decoder $ \(A.At region _) _ err -> - err (Failure region x) - - - --- ERRORS - - -mapError :: (x -> y) -> Decoder x a -> Decoder y a -mapError func (Decoder decodeA) = - Decoder $ \ast ok err -> - let - err' prob = err (mapErrorHelp func prob) - in - decodeA ast ok err' - - -mapErrorHelp :: (x -> y) -> Problem x -> Problem y -mapErrorHelp func problem = - case problem of - Field k p -> Field k (mapErrorHelp func p) - Index i p -> Index i (mapErrorHelp func p) - OneOf p ps -> OneOf (mapErrorHelp func p) (map (mapErrorHelp func) ps) - Failure r x -> Failure r (func x) - Expecting r e -> Expecting r e - - - --- AST - - -type AST = - A.Located AST_ - - -data AST_ - = Array [AST] - | Object [(P.Snippet, AST)] - | String P.Snippet - | Int Int - | TRUE - | FALSE - | NULL - - - --- PARSE - - -type Parser a = - P.Parser ParseError a - - -data ParseError - = Start Row Col - | ObjectField Row Col - | ObjectColon Row Col - | ObjectEnd Row Col - | ArrayEnd Row Col - | StringProblem StringProblem Row Col - | NoLeadingZeros Row Col - | NoFloats Row Col - | BadEnd Row Col - --- PIndex Int ParseError Row Col --- PField Json.String ParseError Row Col - - -data StringProblem - = BadStringEnd - | BadStringControlChar - | BadStringEscapeChar - | BadStringEscapeHex - - - --- PARSE AST - - -pFile :: Parser AST -pFile = - do spaces - value <- pValue - spaces - return value - - -pValue :: Parser AST -pValue = - P.addLocation $ - P.oneOf Start - [ String <$> pString Start - , pObject - , pArray - , pInt - , K.k4 0x74 0x72 0x75 0x65 Start >> return TRUE - , K.k5 0x66 0x61 0x6C 0x73 0x65 Start >> return FALSE - , K.k4 0x6E 0x75 0x6C 0x6C Start >> return NULL - ] - - - --- OBJECT - - -pObject :: Parser AST_ -pObject = - do P.word1 0x7B {- { -} Start - spaces - P.oneOf ObjectField - [ do entry <- pField - spaces - pObjectHelp [entry] - , do P.word1 0x7D {-}-} ObjectEnd - return (Object []) - ] - - -pObjectHelp :: [(P.Snippet, AST)] -> Parser AST_ -pObjectHelp revEntries = - P.oneOf ObjectEnd - [ - do P.word1 0x2C {-,-} ObjectEnd - spaces - entry <- pField - spaces - pObjectHelp (entry:revEntries) - , - do P.word1 0x7D {-}-} ObjectEnd - return (Object (reverse revEntries)) - ] - - -pField :: Parser (P.Snippet, AST) -pField = - do key <- pString ObjectField - spaces - P.word1 0x3A {-:-} ObjectColon - spaces - value <- pValue - return (key, value) - - - --- ARRAY - - -pArray :: Parser AST_ -pArray = - do P.word1 0x5B {-[-} Start - spaces - P.oneOf Start - [ do entry <- pValue - spaces - pArrayHelp 1 [entry] - , do P.word1 0x5D {-]-} ArrayEnd - return (Array []) - ] - - -pArrayHelp :: Int -> [AST] -> Parser AST_ -pArrayHelp !len revEntries = - P.oneOf ArrayEnd - [ - do P.word1 0x2C {-,-} ArrayEnd - spaces - entry <- pValue - spaces - pArrayHelp (len + 1) (entry:revEntries) - , - do P.word1 0x5D {-]-} ArrayEnd - return (Array (reverse revEntries)) - ] - - - --- STRING - - -pString :: (Row -> Col -> ParseError) -> Parser P.Snippet -pString start = - P.Parser $ \(P.State src pos end indent row col) cok _ cerr eerr -> - if pos < end && P.unsafeIndex pos == 0x22 {-"-} then - - let - !pos1 = plusPtr pos 1 - !col1 = col + 1 - - (# status, newPos, newRow, newCol #) = - pStringHelp pos1 end row col1 - in - case status of - GoodString -> - let - !off = minusPtr pos1 (unsafeForeignPtrToPtr src) - !len = minusPtr newPos pos1 - 1 - !snp = P.Snippet src off len row col1 - !newState = P.State src newPos end indent newRow newCol - in - cok snp newState - - BadString problem -> - cerr newRow newCol (StringProblem problem) - - else - eerr row col start - - -data StringStatus - = GoodString - | BadString StringProblem - - -pStringHelp :: Ptr Word8 -> Ptr Word8 -> Row -> Col -> (# StringStatus, Ptr Word8, Row, Col #) -pStringHelp pos end row col = - if pos >= end then - (# BadString BadStringEnd, pos, row, col #) - - else - case P.unsafeIndex pos of - 0x22 {-"-} -> - (# GoodString, plusPtr pos 1, row, col + 1 #) - - 0x0A {-\n-} -> - (# BadString BadStringEnd, pos, row, col #) - - 0x5C {-\-} -> - let !pos1 = plusPtr pos 1 in - if pos1 >= end then - (# BadString BadStringEnd, pos1, row + 1, col #) - else - case P.unsafeIndex pos1 of - 0x22 {-"-} -> pStringHelp (plusPtr pos 2) end row (col + 2) - 0x5C {-\-} -> pStringHelp (plusPtr pos 2) end row (col + 2) - 0x2F {-/-} -> pStringHelp (plusPtr pos 2) end row (col + 2) - 0x62 {-b-} -> pStringHelp (plusPtr pos 2) end row (col + 2) - 0x66 {-f-} -> pStringHelp (plusPtr pos 2) end row (col + 2) - 0x6E {-n-} -> pStringHelp (plusPtr pos 2) end row (col + 2) - 0x72 {-r-} -> pStringHelp (plusPtr pos 2) end row (col + 2) - 0x74 {-t-} -> pStringHelp (plusPtr pos 2) end row (col + 2) - 0x75 {-u-} -> - let !pos6 = plusPtr pos 6 in - if pos6 <= end - && isHex (P.unsafeIndex (plusPtr pos 2)) - && isHex (P.unsafeIndex (plusPtr pos 3)) - && isHex (P.unsafeIndex (plusPtr pos 4)) - && isHex (P.unsafeIndex (plusPtr pos 5)) - then - pStringHelp pos6 end row (col + 6) - else - (# BadString BadStringEscapeHex, pos, row, col #) - - _ -> - (# BadString BadStringEscapeChar, pos, row, col #) - - word -> - if word < 0x20 then - (# BadString BadStringControlChar, pos, row, col #) - else - let !newPos = plusPtr pos (P.getCharWidth word) in - pStringHelp newPos end row (col + 1) - - -isHex :: Word8 -> Bool -isHex word = - 0x30 {-0-} <= word && word <= 0x39 {-9-} - || 0x61 {-a-} <= word && word <= 0x66 {-f-} - || 0x41 {-A-} <= word && word <= 0x46 {-F-} - - - --- SPACES - - -spaces :: Parser () -spaces = - P.Parser $ \state@(P.State src pos end indent row col) cok eok _ _ -> - let - (# newPos, newRow, newCol #) = - eatSpaces pos end row col - in - if pos == newPos then - eok () state - else - let - !newState = - P.State src newPos end indent newRow newCol - in - cok () newState - - -eatSpaces :: Ptr Word8 -> Ptr Word8 -> Row -> Col -> (# Ptr Word8, Row, Col #) -eatSpaces pos end row col = - if pos >= end then - (# pos, row, col #) - - else - case P.unsafeIndex pos of - 0x20 {- -} -> eatSpaces (plusPtr pos 1) end row (col + 1) - 0x09 {-\t-} -> eatSpaces (plusPtr pos 1) end row (col + 1) - 0x0A {-\n-} -> eatSpaces (plusPtr pos 1) end (row + 1) 1 - 0x0D {-\r-} -> eatSpaces (plusPtr pos 1) end row col - _ -> - (# pos, row, col #) - - - --- INTS - - -pInt :: Parser AST_ -pInt = - P.Parser $ \(P.State src pos end indent row col) cok _ cerr eerr -> - if pos >= end then - eerr row col Start - - else - let !word = P.unsafeIndex pos in - if not (isDecimalDigit word) then - eerr row col Start - - else if word == 0x30 {-0-} then - - let - !pos1 = plusPtr pos 1 - !newState = P.State src pos1 end indent row (col + 1) - in - if pos1 < end then - let !word1 = P.unsafeIndex pos1 in - if isDecimalDigit word1 then - cerr row (col + 1) NoLeadingZeros - else if word1 == 0x2E {-.-} then - cerr row (col + 1) NoFloats - else - cok (Int 0) newState - else - cok (Int 0) newState - - else - let - (# status, n, newPos #) = - chompInt (plusPtr pos 1) end (fromIntegral (word - 0x30 {-0-})) - - !len = fromIntegral (minusPtr newPos pos) - in - case status of - GoodInt -> - let - !newState = - P.State src newPos end indent row (col + len) - in - cok (Int n) newState - - BadIntEnd -> - cerr row (col + len) NoFloats - - -data IntStatus = GoodInt | BadIntEnd - - -chompInt :: Ptr Word8 -> Ptr Word8 -> Int -> (# IntStatus, Int, Ptr Word8 #) -chompInt pos end n = - if pos < end then - let !word = P.unsafeIndex pos in - if isDecimalDigit word then - let !m = 10 * n + fromIntegral (word - 0x30 {-0-}) in - chompInt (plusPtr pos 1) end m - else if word == 0x2E {-.-} || word == 0x65 {-e-} || word == 0x45 {-E-} then - (# BadIntEnd, n, pos #) - else - (# GoodInt, n, pos #) - - else - (# GoodInt, n, pos #) - - -{-# INLINE isDecimalDigit #-} -isDecimalDigit :: Word8 -> Bool -isDecimalDigit word = - word <= 0x39 {-9-} && word >= 0x30 {-0-} diff --git a/compiler/src/Json/Encode.hs b/compiler/src/Json/Encode.hs deleted file mode 100644 index 8740ebc560..0000000000 --- a/compiler/src/Json/Encode.hs +++ /dev/null @@ -1,310 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE OverloadedStrings #-} -module Json.Encode - ( write - , encode - , writeUgly - , encodeUgly - , Value(..) - , array - , object - , string - , name - , chars - , bool - , int - , number - , null - , dict - , list - , (==>) - ) - where - - -import Prelude hiding (null) -import Control.Arrow ((***)) -import qualified Data.ByteString.Char8 as BSC -import qualified Data.ByteString.Builder as B -import qualified Data.Map as Map -import qualified Data.Scientific as Sci -import Data.Monoid ((<>)) -import qualified Data.Name as Name -import qualified Data.Utf8 as Utf8 - -import qualified File -import qualified Json.String as Json - - - --- VALUES - - -data Value - = Array [Value] - | Object [(Json.String, Value)] - | String B.Builder - | Boolean Bool - | Integer Int - | Number Sci.Scientific - | Null - - -array :: [Value] -> Value -array = - Array - - -object :: [(Json.String, Value)] -> Value -object = - Object - - -string :: Json.String -> Value -string str = - String (B.char7 '"' <> Json.toBuilder str <> B.char7 '"') - - -name :: Name.Name -> Value -name nm = - String (B.char7 '"' <> Name.toBuilder nm <> B.char7 '"') - - -bool :: Bool -> Value -bool = - Boolean - - -int :: Int -> Value -int = - Integer - - -number :: Sci.Scientific -> Value -number = - Number - - -null :: Value -null = - Null - - -dict :: (k -> Json.String) -> (v -> Value) -> Map.Map k v -> Value -dict encodeKey encodeValue pairs = - Object $ map (encodeKey *** encodeValue) (Map.toList pairs) - - -list :: (a -> Value) -> [a] -> Value -list encodeEntry entries = - Array $ map encodeEntry entries - - - --- CHARS - - -chars :: [Char] -> Value -- PERF can this be done better? Look for examples. -chars chrs = - String (B.char7 '"' <> B.stringUtf8 (escape chrs) <> B.char7 '"') - - -escape :: [Char] -> [Char] -escape chrs = - case chrs of - [] -> - [] - - c:cs - | c == '\r' -> '\\' : 'r' : escape cs - | c == '\n' -> '\\' : 'n' : escape cs - | c == '\"' -> '\\' : '"' : escape cs - | c == '\\' -> '\\' : '\\' : escape cs - | otherwise -> c : escape cs - - - --- HELPERS - - -(==>) :: [Char] -> value -> (Json.String, value) -(==>) key value = - (Json.fromChars key, value) - - - --- WRITE TO FILE - - -write :: FilePath -> Value -> IO () -write path value = - File.writeBuilder path (encode value <> "\n") - - -writeUgly :: FilePath -> Value -> IO () -writeUgly path value = - File.writeBuilder path (encodeUgly value) - - - --- ENCODE UGLY - - -encodeUgly :: Value -> B.Builder -encodeUgly value = - case value of - Array [] -> - B.string7 "[]" - - Array (first : rest) -> - let - encodeEntry entry = - B.char7 ',' <> encodeUgly entry - in - B.char7 '[' <> encodeUgly first <> mconcat (map encodeEntry rest) <> B.char7 ']' - - Object [] -> - B.string7 "{}" - - Object (first : rest) -> - let - encodeEntry char (key, entry) = - B.char7 char <> B.char7 '"' <> Utf8.toBuilder key <> B.string7 "\":" <> encodeUgly entry - in - encodeEntry '{' first <> mconcat (map (encodeEntry ',') rest) <> B.char7 '}' - - String builder -> - builder - - Boolean boolean -> - B.string7 (if boolean then "true" else "false") - - Integer n -> - B.intDec n - - Number scientific -> - B.string7 (Sci.formatScientific Sci.Generic Nothing scientific) - - Null -> - "null" - - - --- ENCODE - - -encode :: Value -> B.Builder -encode value = - encodeHelp "" value - - -encodeHelp :: BSC.ByteString -> Value -> B.Builder -encodeHelp indent value = - case value of - Array [] -> - B.string7 "[]" - - Array (first : rest) -> - encodeArray indent first rest - - Object [] -> - B.string7 "{}" - - Object (first : rest) -> - encodeObject indent first rest - - String builder -> - builder - - Boolean boolean -> - B.string7 (if boolean then "true" else "false") - - Integer n -> - B.intDec n - - Number scientific -> - B.string7 (Sci.formatScientific Sci.Generic Nothing scientific) - - Null -> - "null" - - - --- ENCODE ARRAY - - -encodeArray :: BSC.ByteString -> Value -> [Value] -> B.Builder -encodeArray = - encodeSequence arrayOpen arrayClose encodeHelp - - -arrayOpen :: B.Builder -arrayOpen = - B.string7 "[\n" - - -arrayClose :: B.Builder -arrayClose = - B.char7 ']' - - - --- ENCODE OBJECT - - -encodeObject :: BSC.ByteString -> (Json.String, Value) -> [(Json.String, Value)] -> B.Builder -encodeObject = - encodeSequence objectOpen objectClose encodeField - - -objectOpen :: B.Builder -objectOpen = - B.string7 "{\n" - - -objectClose :: B.Builder -objectClose = - B.char7 '}' - - -encodeField :: BSC.ByteString -> (Json.String, Value) -> B.Builder -encodeField indent (key, value) = - B.char7 '"' <> Utf8.toBuilder key <> B.string7 "\": " <> encodeHelp indent value - - - --- ENCODE SEQUENCE - - -encodeSequence :: B.Builder -> B.Builder -> (BSC.ByteString -> a -> B.Builder) -> BSC.ByteString -> a -> [a] -> B.Builder -encodeSequence open close encodeEntry indent first rest = - let - newIndent = - indent <> " " - - newIndentBuilder = - B.byteString newIndent - - closer = - newline <> B.byteString indent <> close - - addValue field builder = - commaNewline - <> newIndentBuilder - <> encodeEntry newIndent field - <> builder - in - open - <> newIndentBuilder - <> encodeEntry newIndent first - <> foldr addValue closer rest - - -commaNewline :: B.Builder -commaNewline = - B.string7 ",\n" - - -newline :: B.Builder -newline = - B.char7 '\n' diff --git a/compiler/src/Json/String.hs b/compiler/src/Json/String.hs deleted file mode 100644 index 7ed1721ad6..0000000000 --- a/compiler/src/Json/String.hs +++ /dev/null @@ -1,192 +0,0 @@ -{-# OPTIONS_GHC -Wall -fno-warn-name-shadowing #-} -{-# LANGUAGE BangPatterns, EmptyDataDecls #-} -module Json.String - ( String - , isEmpty - -- - , fromPtr - , fromName - , fromChars - , fromSnippet - , fromComment - -- - , toChars - , toBuilder - ) - where - - -import Prelude hiding (String) -import qualified Data.ByteString.Builder as B -import qualified Data.Coerce as Coerce -import qualified Data.Name as Name -import qualified Data.Utf8 as Utf8 -import Data.Utf8 (MBA, newByteArray, copyFromPtr, freeze, writeWord8) -import Data.Word (Word8) -import Foreign.Ptr (Ptr, plusPtr, minusPtr) -import Foreign.ForeignPtr (withForeignPtr) -import GHC.Exts (RealWorld) -import GHC.IO (stToIO, unsafeDupablePerformIO, unsafePerformIO) -import GHC.ST (ST) - -import qualified Parse.Primitives as P - - - --- JSON STRINGS - - --- INVARIANT: any Json.String is appropriately escaped already --- PERF: is this the right representation for Json.String? Maybe ByteString instead? --- -type String = - Utf8.Utf8 JSON_STRING - - -data JSON_STRING - - -isEmpty :: String -> Bool -isEmpty = - Utf8.isEmpty - - - --- FROM - - -fromPtr :: Ptr Word8 -> Ptr Word8 -> String -fromPtr = - Utf8.fromPtr - - -fromChars :: [Char] -> String -fromChars = - Utf8.fromChars - - -fromSnippet :: P.Snippet -> String -fromSnippet = - Utf8.fromSnippet - - -fromName :: Name.Name -> String -fromName = - Coerce.coerce - - - --- TO - - -toChars :: String -> [Char] -toChars = - Utf8.toChars - - -{-# INLINE toBuilder #-} -toBuilder :: String -> B.Builder -toBuilder = - Utf8.toBuilder - - - --- FROM COMMENT - - -fromComment :: P.Snippet -> String -fromComment (P.Snippet fptr off len _ _) = - unsafePerformIO $ withForeignPtr fptr $ \ptr -> - let - !pos = plusPtr ptr off - !end = plusPtr pos len - !str = fromChunks (chompChunks pos end pos []) - in - return str - - -chompChunks :: Ptr Word8 -> Ptr Word8 -> Ptr Word8 -> [Chunk] -> [Chunk] -chompChunks pos end start revChunks = - if pos >= end then - reverse (addSlice start end revChunks) - else - let - !word = P.unsafeIndex pos - in - case word of - 0x0A {-\n-} -> chompEscape 0x6E {-n-} pos end start revChunks - 0x22 {-"-} -> chompEscape 0x22 {-"-} pos end start revChunks - 0x5C {-\-} -> chompEscape 0x5C {-\-} pos end start revChunks - 0x0D {-\r-} -> - let - !newPos = plusPtr pos 1 - in - chompChunks newPos end newPos (addSlice start pos revChunks) - - _ -> - let - !width = P.getCharWidth word - !newPos = plusPtr pos width - in - chompChunks newPos end start revChunks - - -chompEscape :: Word8 -> Ptr Word8 -> Ptr Word8 -> Ptr Word8 -> [Chunk] -> [Chunk] -chompEscape escape pos end start revChunks = - let - !pos1 = plusPtr pos 1 - in - chompChunks pos1 end pos1 (Escape escape : addSlice start pos revChunks) - - -addSlice :: Ptr Word8 -> Ptr Word8 -> [Chunk] -> [Chunk] -addSlice start end revChunks = - if start == end - then revChunks - else Slice start (minusPtr end start) : revChunks - - - --- FROM CHUNKS - - -data Chunk - = Slice (Ptr Word8) Int - | Escape Word8 - - -fromChunks :: [Chunk] -> String -fromChunks chunks = - unsafeDupablePerformIO (stToIO ( - do let !len = sum (map chunkToWidth chunks) - mba <- newByteArray len - writeChunks mba 0 chunks - freeze mba - )) - - -chunkToWidth :: Chunk -> Int -chunkToWidth chunk = - case chunk of - Slice _ len -> len - Escape _ -> 2 - - -writeChunks :: MBA RealWorld -> Int -> [Chunk] -> ST RealWorld () -writeChunks mba offset chunks = - case chunks of - [] -> - return () - - chunk : chunks -> - case chunk of - Slice ptr len -> - do copyFromPtr ptr mba offset len - let !newOffset = offset + len - writeChunks mba newOffset chunks - - Escape word -> - do writeWord8 mba offset 0x5C {- \ -} - writeWord8 mba (offset + 1) word - let !newOffset = offset + 2 - writeChunks mba newOffset chunks diff --git a/compiler/src/Nitpick/Debug.hs b/compiler/src/Nitpick/Debug.hs deleted file mode 100644 index b15b7c0b9e..0000000000 --- a/compiler/src/Nitpick/Debug.hs +++ /dev/null @@ -1,87 +0,0 @@ -module Nitpick.Debug - ( hasDebugUses - ) - where - - -import qualified Data.Map.Utils as Map - -import qualified AST.Optimized as Opt - - - --- HAS DEBUG USES - - -hasDebugUses :: Opt.LocalGraph -> Bool -hasDebugUses (Opt.LocalGraph _ graph _) = - Map.any nodeHasDebug graph - - -nodeHasDebug :: Opt.Node -> Bool -nodeHasDebug node = - case node of - Opt.Define expr _ -> hasDebug expr - Opt.DefineTailFunc _ expr _ -> hasDebug expr - Opt.Ctor _ _ -> False - Opt.Enum _ -> False - Opt.Box -> False - Opt.Link _ -> False - Opt.Cycle _ vs fs _ -> any (hasDebug . snd) vs || any defHasDebug fs - Opt.Manager _ -> False - Opt.Kernel _ _ -> False - Opt.PortIncoming expr _ -> hasDebug expr - Opt.PortOutgoing expr _ -> hasDebug expr - - -hasDebug :: Opt.Expr -> Bool -hasDebug expression = - case expression of - Opt.Bool _ -> False - Opt.Chr _ -> False - Opt.Str _ -> False - Opt.Int _ -> False - Opt.Float _ -> False - Opt.VarLocal _ -> False - Opt.VarGlobal _ -> False - Opt.VarEnum _ _ -> False - Opt.VarBox _ -> False - Opt.VarCycle _ _ -> False - Opt.VarDebug _ _ _ _ -> True - Opt.VarKernel _ _ -> False - Opt.List exprs -> any hasDebug exprs - Opt.Function _ expr -> hasDebug expr - Opt.Call e es -> hasDebug e || any hasDebug es - Opt.TailCall _ args -> any (hasDebug . snd) args - Opt.If conds finally -> any (\(c,e) -> hasDebug c || hasDebug e) conds || hasDebug finally - Opt.Let def body -> defHasDebug def || hasDebug body - Opt.Destruct _ expr -> hasDebug expr - Opt.Case _ _ d jumps -> deciderHasDebug d || any (hasDebug . snd) jumps - Opt.Accessor _ -> False - Opt.Access r _ -> hasDebug r - Opt.Update r fs -> hasDebug r || any hasDebug fs - Opt.Record fs -> any hasDebug fs - Opt.Unit -> False - Opt.Tuple a b c -> hasDebug a || hasDebug b || maybe False hasDebug c - Opt.Shader _ _ _ -> False - - -defHasDebug :: Opt.Def -> Bool -defHasDebug def = - case def of - Opt.Def _ expr -> hasDebug expr - Opt.TailDef _ _ expr -> hasDebug expr - - -deciderHasDebug :: Opt.Decider Opt.Choice -> Bool -deciderHasDebug decider = - case decider of - Opt.Leaf (Opt.Inline expr) -> hasDebug expr - Opt.Leaf (Opt.Jump _) -> False - Opt.Chain _ success failure -> deciderHasDebug success || deciderHasDebug failure - Opt.FanOut _ tests fallback -> any (deciderHasDebug . snd) tests || deciderHasDebug fallback - - - --- TODO: FIND GLOBALLY UNUSED DEFINITIONS? --- TODO: FIND PACKAGE USAGE STATS? (e.g. elm/core = 142, author/project = 2, etc.) diff --git a/compiler/src/Nitpick/PatternMatches.hs b/compiler/src/Nitpick/PatternMatches.hs deleted file mode 100644 index f03db1f8a0..0000000000 --- a/compiler/src/Nitpick/PatternMatches.hs +++ /dev/null @@ -1,653 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE OverloadedStrings #-} -module Nitpick.PatternMatches - ( check - , Error(..) - , Context(..) - , Pattern(..) - , Literal(..) - ) - where - - -{- The algorithm used here comes from "Warnings for Pattern Matching" -by Luc Maranget. Check it out for more information! - -http://moscova.inria.fr/~maranget/papers/warn/warn.pdf - --} - -import qualified Data.List as List -import qualified Data.Map as Map -import qualified Data.Maybe as Maybe -import qualified Data.Name as Name -import qualified Data.NonEmptyList as NE - -import qualified AST.Canonical as Can -import qualified Data.Index as Index -import qualified Elm.ModuleName as ModuleName -import qualified Elm.String as ES -import qualified Reporting.Annotation as A - - - --- PATTERN - - -data Pattern - = Anything - | Literal Literal - | Ctor Can.Union Name.Name [Pattern] - - -data Literal - = Chr ES.String - | Str ES.String - | Int Int - deriving (Eq) - - - --- CREATE SIMPLIFIED PATTERNS - - -simplify :: Can.Pattern -> Pattern -simplify (A.At _ pattern) = - case pattern of - Can.PAnything -> - Anything - - Can.PVar _ -> - Anything - - Can.PRecord _ -> - Anything - - Can.PUnit -> - Ctor unit unitName [] - - Can.PTuple a b Nothing -> - Ctor pair pairName [ simplify a, simplify b ] - - Can.PTuple a b (Just c) -> - Ctor triple tripleName [ simplify a, simplify b, simplify c ] - - Can.PCtor _ _ union name _ args -> - Ctor union name $ - map (\(Can.PatternCtorArg _ _ arg) -> simplify arg) args - - Can.PList entries -> - foldr cons nil entries - - Can.PCons hd tl -> - cons hd (simplify tl) - - Can.PAlias subPattern _ -> - simplify subPattern - - Can.PInt int -> - Literal (Int int) - - Can.PStr str -> - Literal (Str str) - - Can.PChr chr -> - Literal (Chr chr) - - Can.PBool union bool -> - Ctor union (if bool then Name.true else Name.false) [] - - -cons :: Can.Pattern -> Pattern -> Pattern -cons hd tl = - Ctor list consName [ simplify hd, tl ] - - -{-# NOINLINE nil #-} -nil :: Pattern -nil = - Ctor list nilName [] - - - --- BUILT-IN UNIONS - - -{-# NOINLINE unit #-} -unit :: Can.Union -unit = - let - ctor = - Can.Ctor unitName Index.first 0 [] - in - Can.Union [] [ ctor ] 1 Can.Normal - - -{-# NOINLINE pair #-} -pair :: Can.Union -pair = - let - ctor = - Can.Ctor pairName Index.first 2 [Can.TVar "a", Can.TVar "b"] - in - Can.Union ["a","b"] [ ctor ] 1 Can.Normal - - -{-# NOINLINE triple #-} -triple :: Can.Union -triple = - let - ctor = - Can.Ctor tripleName Index.first 3 [Can.TVar "a", Can.TVar "b", Can.TVar "c"] - in - Can.Union ["a","b","c"] [ ctor ] 1 Can.Normal - - -{-# NOINLINE list #-} -list :: Can.Union -list = - let - nilCtor = - Can.Ctor nilName Index.first 0 [] - - consCtor = - Can.Ctor consName Index.second 2 - [ Can.TVar "a" - , Can.TType ModuleName.list Name.list [Can.TVar "a"] - ] - in - Can.Union ["a"] [ nilCtor, consCtor ] 2 Can.Normal - - -{-# NOINLINE unitName #-} -unitName :: Name.Name -unitName = "#0" - - -{-# NOINLINE pairName #-} -pairName :: Name.Name -pairName = "#2" - - -{-# NOINLINE tripleName #-} -tripleName :: Name.Name -tripleName = "#3" - - -{-# NOINLINE consName #-} -consName :: Name.Name -consName = "::" - - -{-# NOINLINE nilName #-} -nilName :: Name.Name -nilName = "[]" - - - --- ERROR - - -data Error - = Incomplete A.Region Context [Pattern] - | Redundant A.Region A.Region Int - - -data Context - = BadArg - | BadDestruct - | BadCase - - - --- CHECK - - -check :: Can.Module -> Either (NE.List Error) () -check (Can.Module _ _ _ decls _ _ _ _) = - case checkDecls decls [] of - [] -> - Right () - - e:es -> - Left (NE.List e es) - - - --- CHECK DECLS - - -checkDecls :: Can.Decls -> [Error] -> [Error] -checkDecls decls errors = - case decls of - Can.Declare def subDecls -> - checkDef def $ checkDecls subDecls errors - - Can.DeclareRec def defs subDecls -> - checkDef def (foldr checkDef (checkDecls subDecls errors) defs) - - Can.SaveTheEnvironment -> - errors - - - --- CHECK DEFS - - -checkDef :: Can.Def -> [Error] -> [Error] -checkDef def errors = - case def of - Can.Def _ args body -> - foldr checkArg (checkExpr body errors) args - - Can.TypedDef _ _ args body _ -> - foldr checkTypedArg (checkExpr body errors) args - - -checkArg :: Can.Pattern -> [Error] -> [Error] -checkArg pattern@(A.At region _) errors = - checkPatterns region BadArg [pattern] errors - - -checkTypedArg :: (Can.Pattern, tipe) -> [Error] -> [Error] -checkTypedArg (pattern@(A.At region _), _) errors = - checkPatterns region BadArg [pattern] errors - - - --- CHECK EXPRESSIONS - - -checkExpr :: Can.Expr -> [Error] -> [Error] -checkExpr (A.At region expression) errors = - case expression of - Can.VarLocal _ -> - errors - - Can.VarTopLevel _ _ -> - errors - - Can.VarKernel _ _ -> - errors - - Can.VarForeign _ _ _ -> - errors - - Can.VarCtor _ _ _ _ _ -> - errors - - Can.VarDebug _ _ _ -> - errors - - Can.VarOperator _ _ _ _ -> - errors - - Can.Chr _ -> - errors - - Can.Str _ -> - errors - - Can.Int _ -> - errors - - Can.Float _ -> - errors - - Can.List entries -> - foldr checkExpr errors entries - - Can.Negate expr -> - checkExpr expr errors - - Can.Binop _ _ _ _ left right -> - checkExpr left $ - checkExpr right errors - - Can.Lambda args body -> - foldr checkArg (checkExpr body errors) args - - Can.Call func args -> - checkExpr func $ foldr checkExpr errors args - - Can.If branches finally -> - foldr checkIfBranch (checkExpr finally errors) branches - - Can.Let def body -> - checkDef def $ checkExpr body errors - - Can.LetRec defs body -> - foldr checkDef (checkExpr body errors) defs - - Can.LetDestruct pattern@(A.At reg _) expr body -> - checkPatterns reg BadDestruct [pattern] $ - checkExpr expr $ checkExpr body errors - - Can.Case expr branches -> - checkExpr expr $ checkCases region branches errors - - Can.Accessor _ -> - errors - - Can.Access record _ -> - checkExpr record errors - - Can.Update _ record fields -> - checkExpr record $ Map.foldr checkField errors fields - - Can.Record fields -> - Map.foldr checkExpr errors fields - - Can.Unit -> - errors - - Can.Tuple a b maybeC -> - checkExpr a $ - checkExpr b $ - case maybeC of - Nothing -> - errors - - Just c -> - checkExpr c errors - - Can.Shader _ _ -> - errors - - - --- CHECK FIELD - - -checkField :: Can.FieldUpdate -> [Error] -> [Error] -checkField (Can.FieldUpdate _ expr) errors = - checkExpr expr errors - - - --- CHECK IF BRANCH - - -checkIfBranch :: (Can.Expr, Can.Expr) -> [Error] -> [Error] -checkIfBranch (condition, branch) errs = - checkExpr condition $ checkExpr branch errs - - - --- CHECK CASE EXPRESSION - - -checkCases :: A.Region -> [Can.CaseBranch] -> [Error] -> [Error] -checkCases region branches errors = - let - (patterns, newErrors) = - foldr checkCaseBranch ([], errors) branches - in - checkPatterns region BadCase patterns newErrors - - -checkCaseBranch :: Can.CaseBranch -> ([Can.Pattern], [Error]) -> ([Can.Pattern], [Error]) -checkCaseBranch (Can.CaseBranch pattern expr) (patterns, errors) = - ( pattern:patterns - , checkExpr expr errors - ) - - - --- CHECK PATTERNS - - -checkPatterns :: A.Region -> Context -> [Can.Pattern] -> [Error] -> [Error] -checkPatterns region context patterns errors = - case toNonRedundantRows region patterns of - Left err -> - err:errors - - Right matrix -> - case isExhaustive matrix 1 of - [] -> - errors - - badPatterns -> - Incomplete region context (map head badPatterns) : errors - - - --- EXHAUSTIVE PATTERNS - - --- INVARIANTS: --- --- The initial rows "matrix" are all of length 1 --- The initial count of items per row "n" is also 1 --- The resulting rows are examples of missing patterns --- -isExhaustive :: [[Pattern]] -> Int -> [[Pattern]] -isExhaustive matrix n = - case matrix of - [] -> - [replicate n Anything] - - _ -> - if n == 0 then - [] - else - let - ctors = collectCtors matrix - numSeen = Map.size ctors - in - if numSeen == 0 then - (:) Anything - <$> isExhaustive (Maybe.mapMaybe specializeRowByAnything matrix) (n - 1) - - else - let alts@(Can.Union _ altList numAlts _) = snd (Map.findMin ctors) in - if numSeen < numAlts then - (:) - <$> Maybe.mapMaybe (isMissing alts ctors) altList - <*> isExhaustive (Maybe.mapMaybe specializeRowByAnything matrix) (n - 1) - - else - let - isAltExhaustive (Can.Ctor name _ arity _) = - recoverCtor alts name arity <$> - isExhaustive - (Maybe.mapMaybe (specializeRowByCtor name arity) matrix) - (arity + n - 1) - in - concatMap isAltExhaustive altList - - -isMissing :: Can.Union -> Map.Map Name.Name a -> Can.Ctor -> Maybe Pattern -isMissing union ctors (Can.Ctor name _ arity _) = - if Map.member name ctors then - Nothing - else - Just (Ctor union name (replicate arity Anything)) - - -recoverCtor :: Can.Union -> Name.Name -> Int -> [Pattern] -> [Pattern] -recoverCtor union name arity patterns = - let - (args, rest) = - splitAt arity patterns - in - Ctor union name args : rest - - - --- REDUNDANT PATTERNS - - --- INVARIANT: Produces a list of rows where (forall row. length row == 1) -toNonRedundantRows :: A.Region -> [Can.Pattern] -> Either Error [[Pattern]] -toNonRedundantRows region patterns = - toSimplifiedUsefulRows region [] patterns - - --- INVARIANT: Produces a list of rows where (forall row. length row == 1) -toSimplifiedUsefulRows :: A.Region -> [[Pattern]] -> [Can.Pattern] -> Either Error [[Pattern]] -toSimplifiedUsefulRows overallRegion checkedRows uncheckedPatterns = - case uncheckedPatterns of - [] -> - Right checkedRows - - pattern@(A.At region _) : rest -> - let nextRow = [simplify pattern] in - if isUseful checkedRows nextRow then - toSimplifiedUsefulRows overallRegion (nextRow : checkedRows) rest - else - Left (Redundant overallRegion region (length checkedRows + 1)) - - --- Check if a new row "vector" is useful given previous rows "matrix" -isUseful :: [[Pattern]] -> [Pattern] -> Bool -isUseful matrix vector = - case matrix of - [] -> - -- No rows are the same as the new vector! The vector is useful! - True - - _ -> - case vector of - [] -> - -- There is nothing left in the new vector, but we still have - -- rows that match the same things. This is not a useful vector! - False - - firstPattern : patterns -> - case firstPattern of - Ctor _ name args -> - -- keep checking rows that start with this Ctor or Anything - isUseful - (Maybe.mapMaybe (specializeRowByCtor name (length args)) matrix) - (args ++ patterns) - - Anything -> - -- check if all alts appear in matrix - case isComplete matrix of - No -> - -- This Anything is useful because some Ctors are missing. - -- But what if a previous row has an Anything? - -- If so, this one is not useful. - isUseful (Maybe.mapMaybe specializeRowByAnything matrix) patterns - - Yes alts -> - -- All Ctors are covered, so this Anything is not needed for any - -- of those. But what if some of those Ctors have subpatterns - -- that make them less general? If so, this actually is useful! - let - isUsefulAlt (Can.Ctor name _ arity _) = - isUseful - (Maybe.mapMaybe (specializeRowByCtor name arity) matrix) - (replicate arity Anything ++ patterns) - in - any isUsefulAlt alts - - Literal literal -> - -- keep checking rows that start with this Literal or Anything - isUseful - (Maybe.mapMaybe (specializeRowByLiteral literal) matrix) - patterns - - --- INVARIANT: (length row == N) ==> (length result == arity + N - 1) -specializeRowByCtor :: Name.Name -> Int -> [Pattern] -> Maybe [Pattern] -specializeRowByCtor ctorName arity row = - case row of - Ctor _ name args : patterns -> - if name == ctorName then - Just (args ++ patterns) - else - Nothing - - Anything : patterns -> - Just (replicate arity Anything ++ patterns) - - Literal _ : _ -> - error $ - "Compiler bug! After type checking, constructors and literals\ - \ should never align in pattern match exhaustiveness checks." - - [] -> - error "Compiler error! Empty matrices should not get specialized." - - --- INVARIANT: (length row == N) ==> (length result == N-1) -specializeRowByLiteral :: Literal -> [Pattern] -> Maybe [Pattern] -specializeRowByLiteral literal row = - case row of - Literal lit : patterns -> - if lit == literal then - Just patterns - else - Nothing - - Anything : patterns -> - Just patterns - - Ctor _ _ _ : _ -> - error $ - "Compiler bug! After type checking, constructors and literals\ - \ should never align in pattern match exhaustiveness checks." - - [] -> - error "Compiler error! Empty matrices should not get specialized." - - --- INVARIANT: (length row == N) ==> (length result == N-1) -specializeRowByAnything :: [Pattern] -> Maybe [Pattern] -specializeRowByAnything row = - case row of - [] -> - Nothing - - Ctor _ _ _ : _ -> - Nothing - - Anything : patterns -> - Just patterns - - Literal _ : _ -> - Nothing - - - --- ALL CONSTRUCTORS ARE PRESENT? - - -data Complete - = Yes [Can.Ctor] - | No - - -isComplete :: [[Pattern]] -> Complete -isComplete matrix = - let - ctors = collectCtors matrix - numSeen = Map.size ctors - in - if numSeen == 0 then - No - else - let (Can.Union _ alts numAlts _) = snd (Map.findMin ctors) in - if numSeen == numAlts then Yes alts else No - - - --- COLLECT CTORS - - -collectCtors :: [[Pattern]] -> Map.Map Name.Name Can.Union -collectCtors matrix = - List.foldl' collectCtorsHelp Map.empty matrix - - -collectCtorsHelp :: Map.Map Name.Name Can.Union -> [Pattern] -> Map.Map Name.Name Can.Union -collectCtorsHelp ctors row = - case row of - Ctor union name _ : _ -> - Map.insert name union ctors - - _ -> - ctors diff --git a/compiler/src/Optimize/Case.hs b/compiler/src/Optimize/Case.hs deleted file mode 100644 index 55b5313f3d..0000000000 --- a/compiler/src/Optimize/Case.hs +++ /dev/null @@ -1,161 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -module Optimize.Case - ( optimize - ) - where - - -import Control.Arrow (second) -import qualified Data.Map as Map -import Data.Map ((!)) -import qualified Data.Maybe as Maybe -import qualified Data.Name as Name - -import qualified AST.Canonical as Can -import qualified AST.Optimized as Opt -import qualified Optimize.DecisionTree as DT - - - --- OPTIMIZE A CASE EXPRESSION - - -optimize :: Name.Name -> Name.Name -> [(Can.Pattern, Opt.Expr)] -> Opt.Expr -optimize temp root optBranches = - let - (patterns, indexedBranches) = - unzip (zipWith indexify [0..] optBranches) - - decider = treeToDecider (DT.compile patterns) - targetCounts = countTargets decider - - (choices, maybeJumps) = - unzip (map (createChoices targetCounts) indexedBranches) - in - Opt.Case temp root - (insertChoices (Map.fromList choices) decider) - (Maybe.catMaybes maybeJumps) - - -indexify :: Int -> (a,b) -> ((a,Int), (Int,b)) -indexify index (pattern, branch) = - ( (pattern, index) - , (index, branch) - ) - - - --- TREE TO DECIDER --- --- Decision trees may have some redundancies, so we convert them to a Decider --- which has special constructs to avoid code duplication when possible. - - -treeToDecider :: DT.DecisionTree -> Opt.Decider Int -treeToDecider tree = - case tree of - DT.Match target -> - Opt.Leaf target - - -- zero options - DT.Decision _ [] Nothing -> - error "compiler bug, somehow created an empty decision tree" - - -- one option - DT.Decision _ [(_, subTree)] Nothing -> - treeToDecider subTree - - DT.Decision _ [] (Just subTree) -> - treeToDecider subTree - - -- two options - DT.Decision path [(test, successTree)] (Just failureTree) -> - toChain path test successTree failureTree - - DT.Decision path [(test, successTree), (_, failureTree)] Nothing -> - toChain path test successTree failureTree - - -- many options - DT.Decision path edges Nothing -> - let - (necessaryTests, fallback) = - (init edges, snd (last edges)) - in - Opt.FanOut - path - (map (second treeToDecider) necessaryTests) - (treeToDecider fallback) - - DT.Decision path edges (Just fallback) -> - Opt.FanOut path (map (second treeToDecider) edges) (treeToDecider fallback) - - -toChain :: DT.Path -> DT.Test -> DT.DecisionTree -> DT.DecisionTree -> Opt.Decider Int -toChain path test successTree failureTree = - let - failure = - treeToDecider failureTree - in - case treeToDecider successTree of - Opt.Chain testChain success subFailure | failure == subFailure -> - Opt.Chain ((path, test) : testChain) success failure - - success -> - Opt.Chain [(path, test)] success failure - - - --- INSERT CHOICES --- --- If a target appears exactly once in a Decider, the corresponding expression --- can be inlined. Whether things are inlined or jumps is called a "choice". - - -countTargets :: Opt.Decider Int -> Map.Map Int Int -countTargets decisionTree = - case decisionTree of - Opt.Leaf target -> - Map.singleton target 1 - - Opt.Chain _ success failure -> - Map.unionWith (+) (countTargets success) (countTargets failure) - - Opt.FanOut _ tests fallback -> - Map.unionsWith (+) (map countTargets (fallback : map snd tests)) - - -createChoices - :: Map.Map Int Int - -> (Int, Opt.Expr) - -> ( (Int, Opt.Choice), Maybe (Int, Opt.Expr) ) -createChoices targetCounts (target, branch) = - if targetCounts ! target == 1 then - ( (target, Opt.Inline branch) - , Nothing - ) - - else - ( (target, Opt.Jump target) - , Just (target, branch) - ) - - -insertChoices - :: Map.Map Int Opt.Choice - -> Opt.Decider Int - -> Opt.Decider Opt.Choice -insertChoices choiceDict decider = - let - go = - insertChoices choiceDict - in - case decider of - Opt.Leaf target -> - Opt.Leaf (choiceDict ! target) - - Opt.Chain testChain success failure -> - Opt.Chain testChain (go success) (go failure) - - Opt.FanOut path tests fallback -> - Opt.FanOut path (map (second go) tests) (go fallback) - diff --git a/compiler/src/Optimize/DecisionTree.hs b/compiler/src/Optimize/DecisionTree.hs deleted file mode 100644 index 466758f727..0000000000 --- a/compiler/src/Optimize/DecisionTree.hs +++ /dev/null @@ -1,637 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE OverloadedStrings #-} -module Optimize.DecisionTree - ( DecisionTree(..) - , compile - , Path(..) - , Test(..) - ) - where - - -{- To learn more about how this works, definitely read through: - - "When Do Match-Compilation Heuristics Matter?" - -by Kevin Scott and Norman Ramsey. The rough idea is that we start with a simple -list of patterns and expressions, and then turn that into a "decision tree" -that requires as few tests as possible to make it to a leaf. Read the paper, it -explains this extraordinarily well! We are currently using the same heuristics -as SML/NJ to get nice trees. --} - -import Control.Arrow (second) -import Control.Monad (liftM, liftM2, liftM5) -import Data.Binary -import qualified Data.List as List -import qualified Data.Maybe as Maybe -import qualified Data.Name as Name -import qualified Data.Set as Set - -import qualified AST.Canonical as Can -import qualified Data.Index as Index -import qualified Elm.ModuleName as ModuleName -import qualified Elm.String as ES -import qualified Reporting.Annotation as A - - - --- COMPILE CASES - - -{-| Users of this module will mainly interact with this function. It takes -some normal branches and gives out a decision tree that has "labels" at all -the leafs and a dictionary that maps these "labels" to the code that should -run. - -If 2 or more leaves point to the same label, we need to do some tricks in JS to -make that work nicely. When is JS getting goto?! ;) That is outside the scope -of this module though. --} -compile :: [(Can.Pattern, Int)] -> DecisionTree -compile rawBranches = - let - format (pattern, index) = - Branch index [(Empty, pattern)] - in - toDecisionTree (map format rawBranches) - - - --- DECISION TREES - - -data DecisionTree - = Match Int - | Decision - { _path :: Path - , _edges :: [(Test, DecisionTree)] - , _default :: Maybe DecisionTree - } - deriving (Eq) - - -data Test - = IsCtor ModuleName.Canonical Name.Name Index.ZeroBased Int Can.CtorOpts - | IsCons - | IsNil - | IsTuple - | IsInt Int - | IsChr ES.String - | IsStr ES.String - | IsBool Bool - deriving (Eq, Ord) - - -data Path - = Index Index.ZeroBased Path - | Unbox Path - | Empty - deriving (Eq) - - - --- ACTUALLY BUILD DECISION TREES - - -data Branch = - Branch - { _goal :: Int - , _patterns :: [(Path, Can.Pattern)] - } - - -toDecisionTree :: [Branch] -> DecisionTree -toDecisionTree rawBranches = - let - branches = - map flattenPatterns rawBranches - in - case checkForMatch branches of - Just goal -> - Match goal - - Nothing -> - let - path = - pickPath branches - - (edges, fallback) = - gatherEdges branches path - - decisionEdges = - map (second toDecisionTree) edges - in - case (decisionEdges, fallback) of - ([(_tag, decisionTree)], []) -> - decisionTree - - (_, []) -> - Decision path decisionEdges Nothing - - ([], _ : _) -> - toDecisionTree fallback - - (_, _) -> - Decision path decisionEdges (Just (toDecisionTree fallback)) - - -isComplete :: [Test] -> Bool -isComplete tests = - case head tests of - IsCtor _ _ _ numAlts _ -> - numAlts == length tests - - IsCons -> - length tests == 2 - - IsNil -> - length tests == 2 - - IsTuple -> - True - - IsChr _ -> - False - - IsStr _ -> - False - - IsInt _ -> - False - - IsBool _ -> - length tests == 2 - - - --- FLATTEN PATTERNS - - -{-| Flatten type aliases and use the VariantDict to figure out when a tag is -the only variant so we can skip doing any tests on it. --} -flattenPatterns :: Branch -> Branch -flattenPatterns (Branch goal pathPatterns) = - Branch goal (foldr flatten [] pathPatterns) - - -flatten :: (Path, Can.Pattern) -> [(Path, Can.Pattern)] -> [(Path, Can.Pattern)] -flatten pathPattern@(path, A.At region pattern) otherPathPatterns = - case pattern of - Can.PVar _ -> - pathPattern : otherPathPatterns - - Can.PAnything -> - pathPattern : otherPathPatterns - - Can.PCtor _ _ (Can.Union _ _ numAlts _) _ _ ctorArgs -> - if numAlts == 1 then - case map dearg ctorArgs of - [arg] -> - flatten (Unbox path, arg) otherPathPatterns - - args -> - foldr flatten otherPathPatterns (subPositions path args) - else - pathPattern : otherPathPatterns - - Can.PTuple a b maybeC -> - flatten (Index Index.first path, a) $ - flatten (Index Index.second path, b) $ - case maybeC of - Nothing -> - otherPathPatterns - - Just c -> - flatten (Index Index.third path, c) otherPathPatterns - - Can.PUnit -> - otherPathPatterns - - Can.PAlias realPattern alias -> - flatten (path, realPattern) $ - (path, A.At region (Can.PVar alias)) : otherPathPatterns - - Can.PRecord _ -> - pathPattern : otherPathPatterns - - Can.PList _ -> - pathPattern : otherPathPatterns - - Can.PCons _ _ -> - pathPattern : otherPathPatterns - - Can.PChr _ -> - pathPattern : otherPathPatterns - - Can.PStr _ -> - pathPattern : otherPathPatterns - - Can.PInt _ -> - pathPattern : otherPathPatterns - - Can.PBool _ _ -> - pathPattern : otherPathPatterns - - -subPositions :: Path -> [Can.Pattern] -> [(Path, Can.Pattern)] -subPositions path patterns = - Index.indexedMap (\index pattern -> (Index index path, pattern)) patterns - - -dearg :: Can.PatternCtorArg -> Can.Pattern -dearg (Can.PatternCtorArg _ _ pattern) = - pattern - - - --- SUCCESSFULLY MATCH - - -{-| If the first branch has no more "decision points" we can finally take that -path. If that is the case we give the resulting label and a mapping from free -variables to "how to get their value". So a pattern like (Just (x,_)) will give -us something like ("x" => value.0.0) --} -checkForMatch :: [Branch] -> Maybe Int -checkForMatch branches = - case branches of - Branch goal patterns : _ | all (not . needsTests . snd) patterns -> - Just goal - - _ -> - Nothing - - - --- GATHER OUTGOING EDGES - - -gatherEdges :: [Branch] -> Path -> ([(Test, [Branch])], [Branch]) -gatherEdges branches path = - let - relevantTests = - testsAtPath path branches - - allEdges = - map (edgesFor path branches) relevantTests - - fallbacks = - if isComplete relevantTests then - [] - else - filter (isIrrelevantTo path) branches - in - ( allEdges, fallbacks ) - - - --- FIND RELEVANT TESTS - - -testsAtPath :: Path -> [Branch] -> [Test] -testsAtPath selectedPath branches = - let - allTests = - Maybe.mapMaybe (testAtPath selectedPath) branches - - skipVisited test curr@(uniqueTests, visitedTests) = - if Set.member test visitedTests then - curr - else - ( test : uniqueTests - , Set.insert test visitedTests - ) - in - fst (foldr skipVisited ([], Set.empty) allTests) - - -testAtPath :: Path -> Branch -> Maybe Test -testAtPath selectedPath (Branch _ pathPatterns) = - case List.lookup selectedPath pathPatterns of - Nothing -> - Nothing - - Just (A.At _ pattern) -> - case pattern of - Can.PCtor home _ (Can.Union _ _ numAlts opts) name index _ -> - Just (IsCtor home name index numAlts opts) - - Can.PList ps -> - Just (case ps of { [] -> IsNil ; _ -> IsCons }) - - Can.PCons _ _ -> - Just IsCons - - Can.PTuple _ _ _ -> - Just IsTuple - - Can.PUnit -> - Just IsTuple - - Can.PVar _ -> - Nothing - - Can.PAnything -> - Nothing - - Can.PInt int -> - Just (IsInt int) - - Can.PStr str -> - Just (IsStr str) - - Can.PChr chr -> - Just (IsChr chr) - - Can.PBool _ bool -> - Just (IsBool bool) - - Can.PRecord _ -> - Nothing - - Can.PAlias _ _ -> - error "aliases should never reach 'testAtPath' function" - - - --- BUILD EDGES - - -edgesFor :: Path -> [Branch] -> Test -> (Test, [Branch]) -edgesFor path branches test = - ( test - , Maybe.mapMaybe (toRelevantBranch test path) branches - ) - - -toRelevantBranch :: Test -> Path -> Branch -> Maybe Branch -toRelevantBranch test path branch@(Branch goal pathPatterns) = - case extract path pathPatterns of - Found start (A.At region pattern) end -> - case pattern of - Can.PCtor _ _ (Can.Union _ _ numAlts _) name _ ctorArgs -> - case test of - IsCtor _ testName _ _ _ | name == testName -> - Just $ Branch goal $ - case map dearg ctorArgs of - [arg] | numAlts == 1 -> - start ++ [(Unbox path, arg)] ++ end - - args -> - start ++ subPositions path args ++ end - - _ -> - Nothing - - Can.PList [] -> - case test of - IsNil -> - Just (Branch goal (start ++ end)) - - _ -> - Nothing - - Can.PList (hd:tl) -> - case test of - IsCons -> - let tl' = A.At region (Can.PList tl) in - Just (Branch goal (start ++ subPositions path [ hd, tl' ] ++ end)) - - _ -> - Nothing - - Can.PCons hd tl -> - case test of - IsCons -> - Just (Branch goal (start ++ subPositions path [hd,tl] ++ end)) - - _ -> - Nothing - - Can.PChr chr -> - case test of - IsChr testChr | chr == testChr -> - Just (Branch goal (start ++ end)) - _ -> - Nothing - - Can.PStr str -> - case test of - IsStr testStr | str == testStr -> - Just (Branch goal (start ++ end)) - - _ -> - Nothing - - Can.PInt int -> - case test of - IsInt testInt | int == testInt -> - Just (Branch goal (start ++ end)) - - _ -> - Nothing - - Can.PBool _ bool -> - case test of - IsBool testBool | bool == testBool -> - Just (Branch goal (start ++ end)) - - _ -> - Nothing - - Can.PUnit -> - Just (Branch goal (start ++ end)) - - Can.PTuple a b maybeC -> - Just (Branch goal (start ++ subPositions path (a : b : Maybe.maybeToList maybeC) ++ end)) - - Can.PVar _ -> - Just branch - - Can.PAnything -> - Just branch - - Can.PRecord _ -> - Just branch - - Can.PAlias _ _ -> - Just branch - - NotFound -> - Just branch - - -data Extract - = NotFound - | Found [(Path, Can.Pattern)] Can.Pattern [(Path, Can.Pattern)] - - -extract :: Path -> [(Path, Can.Pattern)] -> Extract -extract selectedPath pathPatterns = - case pathPatterns of - [] -> - NotFound - - first@(path, pattern) : rest -> - if path == selectedPath then - Found [] pattern rest - - else - case extract selectedPath rest of - NotFound -> - NotFound - - Found start foundPattern end -> - Found (first : start) foundPattern end - - - --- FIND IRRELEVANT BRANCHES - - -isIrrelevantTo :: Path -> Branch -> Bool -isIrrelevantTo selectedPath (Branch _ pathPatterns) = - case List.lookup selectedPath pathPatterns of - Nothing -> - True - - Just pattern -> - not (needsTests pattern) - - -needsTests :: Can.Pattern -> Bool -needsTests (A.At _ pattern) = - case pattern of - Can.PVar _ -> False - Can.PAnything -> False - Can.PRecord _ -> False - Can.PCtor _ _ _ _ _ _ -> True - Can.PList _ -> True - Can.PCons _ _ -> True - Can.PUnit -> True - Can.PTuple _ _ _ -> True - Can.PChr _ -> True - Can.PStr _ -> True - Can.PInt _ -> True - Can.PBool _ _ -> True - Can.PAlias _ _ -> - error "aliases should never reach 'isIrrelevantTo' function" - - - - --- PICK A PATH - - -pickPath :: [Branch] -> Path -pickPath branches = - let - allPaths = - Maybe.mapMaybe isChoicePath (concatMap _patterns branches) - in - case bests (addWeights (smallDefaults branches) allPaths) of - [path] -> - path - - tiedPaths -> - head (bests (addWeights (smallBranchingFactor branches) tiedPaths)) - - -isChoicePath :: (Path, Can.Pattern) -> Maybe Path -isChoicePath (path, pattern) = - if needsTests pattern then - Just path - else - Nothing - - -addWeights :: (Path -> Int) -> [Path] -> [(Path, Int)] -addWeights toWeight paths = - map (\path -> (path, toWeight path)) paths - - -bests :: [(Path, Int)] -> [Path] -bests allPaths = - case allPaths of - [] -> - error "Cannot choose the best of zero paths. This should never happen." - - (headPath, headWeight) : weightedPaths -> - let - gatherMinimum acc@(minWeight, paths) (path, weight) = - if weight == minWeight then - (minWeight, path : paths) - - else if weight < minWeight then - (weight, [path]) - - else - acc - in - snd (List.foldl' gatherMinimum (headWeight, [headPath]) weightedPaths) - - - --- PATH PICKING HEURISTICS - - -smallDefaults :: [Branch] -> Path -> Int -smallDefaults branches path = - length (filter (isIrrelevantTo path) branches) - - -smallBranchingFactor :: [Branch] -> Path -> Int -smallBranchingFactor branches path = - let - (edges, fallback) = - gatherEdges branches path - in - length edges + (if null fallback then 0 else 1) - - - --- BINARY - - -instance Binary Test where - put test = - case test of - IsCtor a b c d e -> putWord8 0 >> put a >> put b >> put c >> put d >> put e - IsCons -> putWord8 1 - IsNil -> putWord8 2 - IsTuple -> putWord8 3 - IsChr a -> putWord8 4 >> put a - IsStr a -> putWord8 5 >> put a - IsInt a -> putWord8 6 >> put a - IsBool a -> putWord8 7 >> put a - - get = - do word <- getWord8 - case word of - 0 -> liftM5 IsCtor get get get get get - 1 -> pure IsCons - 2 -> pure IsNil - 3 -> pure IsTuple - 4 -> liftM IsChr get - 5 -> liftM IsStr get - 6 -> liftM IsInt get - 7 -> liftM IsBool get - _ -> fail "problem getting DecisionTree.Test binary" - - -instance Binary Path where - put path = - case path of - Index a b -> putWord8 0 >> put a >> put b - Unbox a -> putWord8 1 >> put a - Empty -> putWord8 2 - - get = - do word <- getWord8 - case word of - 0 -> liftM2 Index get get - 1 -> liftM Unbox get - 2 -> pure Empty - _ -> fail "problem getting DecisionTree.Path binary" diff --git a/compiler/src/Optimize/Expression.hs b/compiler/src/Optimize/Expression.hs deleted file mode 100644 index bbe2d40d86..0000000000 --- a/compiler/src/Optimize/Expression.hs +++ /dev/null @@ -1,490 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE OverloadedStrings #-} -module Optimize.Expression - ( optimize - , destructArgs - , optimizePotentialTailCall - ) - where - - -import Prelude hiding (cycle) -import Control.Monad (foldM) -import qualified Data.Map as Map -import qualified Data.Name as Name -import qualified Data.Set as Set - -import qualified AST.Canonical as Can -import qualified AST.Optimized as Opt -import qualified AST.Utils.Shader as Shader -import qualified Data.Index as Index -import qualified Elm.ModuleName as ModuleName -import qualified Optimize.Case as Case -import qualified Optimize.Names as Names -import qualified Reporting.Annotation as A - - - --- OPTIMIZE - - -type Cycle = - Set.Set Name.Name - - -optimize :: Cycle -> Can.Expr -> Names.Tracker Opt.Expr -optimize cycle (A.At region expression) = - case expression of - Can.VarLocal name -> - pure (Opt.VarLocal name) - - Can.VarTopLevel home name -> - if Set.member name cycle then - pure (Opt.VarCycle home name) - else - Names.registerGlobal home name - - Can.VarKernel home name -> - Names.registerKernel home (Opt.VarKernel home name) - - Can.VarForeign home name _ -> - Names.registerGlobal home name - - Can.VarCtor opts home name index _ -> - Names.registerCtor home name index opts - - Can.VarDebug home name _ -> - Names.registerDebug name home region - - Can.VarOperator _ home name _ -> - Names.registerGlobal home name - - Can.Chr chr -> - Names.registerKernel Name.utils (Opt.Chr chr) - - Can.Str str -> - pure (Opt.Str str) - - Can.Int int -> - pure (Opt.Int int) - - Can.Float float -> - pure (Opt.Float float) - - Can.List entries -> - Names.registerKernel Name.list Opt.List - <*> traverse (optimize cycle) entries - - Can.Negate expr -> - do func <- Names.registerGlobal ModuleName.basics Name.negate - arg <- optimize cycle expr - pure $ Opt.Call func [arg] - - Can.Binop _ home name _ left right -> - do optFunc <- Names.registerGlobal home name - optLeft <- optimize cycle left - optRight <- optimize cycle right - return (Opt.Call optFunc [optLeft, optRight]) - - Can.Lambda args body -> - do (argNames, destructors) <- destructArgs args - obody <- optimize cycle body - pure $ Opt.Function argNames (foldr Opt.Destruct obody destructors) - - Can.Call func args -> - Opt.Call - <$> optimize cycle func - <*> traverse (optimize cycle) args - - Can.If branches finally -> - let - optimizeBranch (condition, branch) = - (,) - <$> optimize cycle condition - <*> optimize cycle branch - in - Opt.If - <$> traverse optimizeBranch branches - <*> optimize cycle finally - - Can.Let def body -> - optimizeDef cycle def =<< optimize cycle body - - Can.LetRec defs body -> - case defs of - [def] -> - Opt.Let - <$> optimizePotentialTailCallDef cycle def - <*> optimize cycle body - - _ -> - do obody <- optimize cycle body - foldM (\bod def -> optimizeDef cycle def bod) obody defs - - Can.LetDestruct pattern expr body -> - do (name, destructs) <- destruct pattern - oexpr <- optimize cycle expr - obody <- optimize cycle body - pure $ - Opt.Let (Opt.Def name oexpr) (foldr Opt.Destruct obody destructs) - - Can.Case expr branches -> - let - optimizeBranch root (Can.CaseBranch pattern branch) = - do destructors <- destructCase root pattern - obranch <- optimize cycle branch - pure (pattern, foldr Opt.Destruct obranch destructors) - in - do temp <- Names.generate - oexpr <- optimize cycle expr - case oexpr of - Opt.VarLocal root -> - Case.optimize temp root <$> traverse (optimizeBranch root) branches - - _ -> - do obranches <- traverse (optimizeBranch temp) branches - return $ Opt.Let (Opt.Def temp oexpr) (Case.optimize temp temp obranches) - - Can.Accessor field -> - Names.registerField field (Opt.Accessor field) - - Can.Access record (A.At _ field) -> - do optRecord <- optimize cycle record - Names.registerField field (Opt.Access optRecord field) - - Can.Update _ record updates -> - Names.registerFieldDict updates Opt.Update - <*> optimize cycle record - <*> traverse (optimizeUpdate cycle) updates - - Can.Record fields -> - Names.registerFieldDict fields Opt.Record - <*> traverse (optimize cycle) fields - - Can.Unit -> - Names.registerKernel Name.utils Opt.Unit - - Can.Tuple a b maybeC -> - Names.registerKernel Name.utils Opt.Tuple - <*> optimize cycle a - <*> optimize cycle b - <*> traverse (optimize cycle) maybeC - - Can.Shader src (Shader.Types attributes uniforms _varyings) -> - pure (Opt.Shader src (Map.keysSet attributes) (Map.keysSet uniforms)) - - - --- UPDATE - - -optimizeUpdate :: Cycle -> Can.FieldUpdate -> Names.Tracker Opt.Expr -optimizeUpdate cycle (Can.FieldUpdate _ expr) = - optimize cycle expr - - - --- DEFINITION - - -optimizeDef :: Cycle -> Can.Def -> Opt.Expr -> Names.Tracker Opt.Expr -optimizeDef cycle def body = - case def of - Can.Def (A.At _ name) args expr -> - optimizeDefHelp cycle name args expr body - - Can.TypedDef (A.At _ name) _ typedArgs expr _ -> - optimizeDefHelp cycle name (map fst typedArgs) expr body - - -optimizeDefHelp :: Cycle -> Name.Name -> [Can.Pattern] -> Can.Expr -> Opt.Expr -> Names.Tracker Opt.Expr -optimizeDefHelp cycle name args expr body = - do oexpr <- optimize cycle expr - case args of - [] -> - pure $ Opt.Let (Opt.Def name oexpr) body - - _ -> - do (argNames, destructors) <- destructArgs args - let ofunc = Opt.Function argNames (foldr Opt.Destruct oexpr destructors) - pure $ Opt.Let (Opt.Def name ofunc) body - - - --- DESTRUCTURING - - -destructArgs :: [Can.Pattern] -> Names.Tracker ([Name.Name], [Opt.Destructor]) -destructArgs args = - do (argNames, destructorLists) <- unzip <$> traverse destruct args - return (argNames, concat destructorLists) - - -destructCase :: Name.Name -> Can.Pattern -> Names.Tracker [Opt.Destructor] -destructCase rootName pattern = - reverse <$> destructHelp (Opt.Root rootName) pattern [] - - -destruct :: Can.Pattern -> Names.Tracker (Name.Name, [Opt.Destructor]) -destruct pattern@(A.At _ ptrn) = - case ptrn of - Can.PVar name -> - pure (name, []) - - Can.PAlias subPattern name -> - do revDs <- destructHelp (Opt.Root name) subPattern [] - pure (name, reverse revDs) - - _ -> - do name <- Names.generate - revDs <- destructHelp (Opt.Root name) pattern [] - pure (name, reverse revDs) - - -destructHelp :: Opt.Path -> Can.Pattern -> [Opt.Destructor] -> Names.Tracker [Opt.Destructor] -destructHelp path (A.At region pattern) revDs = - case pattern of - Can.PAnything -> - pure revDs - - Can.PVar name -> - pure (Opt.Destructor name path : revDs) - - Can.PRecord fields -> - let - toDestruct name = - Opt.Destructor name (Opt.Field name path) - in - Names.registerFieldList fields (map toDestruct fields ++ revDs) - - Can.PAlias subPattern name -> - destructHelp (Opt.Root name) subPattern $ - Opt.Destructor name path : revDs - - Can.PUnit -> - pure revDs - - Can.PTuple a b Nothing -> - destructTwo path a b revDs - - Can.PTuple a b (Just c) -> - case path of - Opt.Root _ -> - destructHelp (Opt.Index Index.third path) c =<< - destructHelp (Opt.Index Index.second path) b =<< - destructHelp (Opt.Index Index.first path) a revDs - - _ -> - do name <- Names.generate - let newRoot = Opt.Root name - destructHelp (Opt.Index Index.third newRoot) c =<< - destructHelp (Opt.Index Index.second newRoot) b =<< - destructHelp (Opt.Index Index.first newRoot) a (Opt.Destructor name path : revDs) - - Can.PList [] -> - pure revDs - - Can.PList (hd:tl) -> - destructTwo path hd (A.At region (Can.PList tl)) revDs - - Can.PCons hd tl -> - destructTwo path hd tl revDs - - Can.PChr _ -> - pure revDs - - Can.PStr _ -> - pure revDs - - Can.PInt _ -> - pure revDs - - Can.PBool _ _ -> - pure revDs - - Can.PCtor _ _ (Can.Union _ _ _ opts) _ _ args -> - case args of - [Can.PatternCtorArg _ _ arg] -> - case opts of - Can.Normal -> destructHelp (Opt.Index Index.first path) arg revDs - Can.Unbox -> destructHelp (Opt.Unbox path) arg revDs - Can.Enum -> destructHelp (Opt.Index Index.first path) arg revDs - - _ -> - case path of - Opt.Root _ -> - foldM (destructCtorArg path) revDs args - - _ -> - do name <- Names.generate - foldM (destructCtorArg (Opt.Root name)) (Opt.Destructor name path : revDs) args - - -destructTwo :: Opt.Path -> Can.Pattern -> Can.Pattern -> [Opt.Destructor] -> Names.Tracker [Opt.Destructor] -destructTwo path a b revDs = - case path of - Opt.Root _ -> - destructHelp (Opt.Index Index.second path) b =<< - destructHelp (Opt.Index Index.first path) a revDs - - _ -> - do name <- Names.generate - let newRoot = Opt.Root name - destructHelp (Opt.Index Index.second newRoot) b =<< - destructHelp (Opt.Index Index.first newRoot) a (Opt.Destructor name path : revDs) - - -destructCtorArg :: Opt.Path -> [Opt.Destructor] -> Can.PatternCtorArg -> Names.Tracker [Opt.Destructor] -destructCtorArg path revDs (Can.PatternCtorArg index _ arg) = - destructHelp (Opt.Index index path) arg revDs - - - --- TAIL CALL - - -optimizePotentialTailCallDef :: Cycle -> Can.Def -> Names.Tracker Opt.Def -optimizePotentialTailCallDef cycle def = - case def of - Can.Def (A.At _ name) args expr -> - optimizePotentialTailCall cycle name args expr - - Can.TypedDef (A.At _ name) _ typedArgs expr _ -> - optimizePotentialTailCall cycle name (map fst typedArgs) expr - - -optimizePotentialTailCall :: Cycle -> Name.Name -> [Can.Pattern] -> Can.Expr -> Names.Tracker Opt.Def -optimizePotentialTailCall cycle name args expr = - do (argNames, destructors) <- destructArgs args - toTailDef name argNames destructors <$> - optimizeTail cycle name argNames expr - - -optimizeTail :: Cycle -> Name.Name -> [Name.Name] -> Can.Expr -> Names.Tracker Opt.Expr -optimizeTail cycle rootName argNames locExpr@(A.At _ expression) = - case expression of - Can.Call func args -> - do oargs <- traverse (optimize cycle) args - - let isMatchingName = - case A.toValue func of - Can.VarLocal name -> rootName == name - Can.VarTopLevel _ name -> rootName == name - _ -> False - - if isMatchingName - then - case Index.indexedZipWith (\_ a b -> (a,b)) argNames oargs of - Index.LengthMatch pairs -> - pure $ Opt.TailCall rootName pairs - - Index.LengthMismatch _ _ -> - do ofunc <- optimize cycle func - pure $ Opt.Call ofunc oargs - else - do ofunc <- optimize cycle func - pure $ Opt.Call ofunc oargs - - Can.If branches finally -> - let - optimizeBranch (condition, branch) = - (,) - <$> optimize cycle condition - <*> optimizeTail cycle rootName argNames branch - in - Opt.If - <$> traverse optimizeBranch branches - <*> optimizeTail cycle rootName argNames finally - - Can.Let def body -> - optimizeDef cycle def =<< optimizeTail cycle rootName argNames body - - Can.LetRec defs body -> - case defs of - [def] -> - Opt.Let - <$> optimizePotentialTailCallDef cycle def - <*> optimizeTail cycle rootName argNames body - - _ -> - do obody <- optimizeTail cycle rootName argNames body - foldM (\bod def -> optimizeDef cycle def bod) obody defs - - Can.LetDestruct pattern expr body -> - do (dname, destructors) <- destruct pattern - oexpr <- optimize cycle expr - obody <- optimizeTail cycle rootName argNames body - pure $ - Opt.Let (Opt.Def dname oexpr) (foldr Opt.Destruct obody destructors) - - Can.Case expr branches -> - let - optimizeBranch root (Can.CaseBranch pattern branch) = - do destructors <- destructCase root pattern - obranch <- optimizeTail cycle rootName argNames branch - pure (pattern, foldr Opt.Destruct obranch destructors) - in - do temp <- Names.generate - oexpr <- optimize cycle expr - case oexpr of - Opt.VarLocal root -> - Case.optimize temp root <$> traverse (optimizeBranch root) branches - - _ -> - do obranches <- traverse (optimizeBranch temp) branches - return $ Opt.Let (Opt.Def temp oexpr) (Case.optimize temp temp obranches) - - _ -> - optimize cycle locExpr - - - --- DETECT TAIL CALLS - - -toTailDef :: Name.Name -> [Name.Name] -> [Opt.Destructor] -> Opt.Expr -> Opt.Def -toTailDef name argNames destructors body = - if hasTailCall body then - Opt.TailDef name argNames (foldr Opt.Destruct body destructors) - else - Opt.Def name (Opt.Function argNames (foldr Opt.Destruct body destructors)) - - -hasTailCall :: Opt.Expr -> Bool -hasTailCall expression = - case expression of - Opt.TailCall _ _ -> - True - - Opt.If branches finally -> - hasTailCall finally || any (hasTailCall . snd) branches - - Opt.Let _ body -> - hasTailCall body - - Opt.Destruct _ body -> - hasTailCall body - - Opt.Case _ _ decider jumps -> - decidecHasTailCall decider || any (hasTailCall . snd) jumps - - _ -> - False - - -decidecHasTailCall :: Opt.Decider Opt.Choice -> Bool -decidecHasTailCall decider = - case decider of - Opt.Leaf choice -> - case choice of - Opt.Inline expr -> - hasTailCall expr - - Opt.Jump _ -> - False - - Opt.Chain _ success failure -> - decidecHasTailCall success || decidecHasTailCall failure - - Opt.FanOut _ tests fallback -> - decidecHasTailCall fallback || any (decidecHasTailCall . snd) tests diff --git a/compiler/src/Optimize/Module.hs b/compiler/src/Optimize/Module.hs deleted file mode 100644 index c8127a3d4a..0000000000 --- a/compiler/src/Optimize/Module.hs +++ /dev/null @@ -1,369 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE OverloadedStrings #-} -module Optimize.Module - ( optimize - ) - where - - -import Prelude hiding (cycle) -import Control.Monad (foldM) -import qualified Data.List as List -import qualified Data.Map as Map -import qualified Data.Name as Name -import qualified Data.Set as Set -import Data.Map ((!)) - -import qualified AST.Canonical as Can -import qualified AST.Optimized as Opt -import qualified AST.Utils.Type as Type -import qualified Canonicalize.Effects as Effects -import qualified Elm.ModuleName as ModuleName -import qualified Optimize.Expression as Expr -import qualified Optimize.Names as Names -import qualified Optimize.Port as Port -import qualified Reporting.Annotation as A -import qualified Reporting.Error.Main as E -import qualified Reporting.Result as Result -import qualified Reporting.Warning as W - - - --- OPTIMIZE - - -type Result i w a = - Result.Result i w E.Error a - - -type Annotations = - Map.Map Name.Name Can.Annotation - - -optimize :: Annotations -> Can.Module -> Result i [W.Warning] Opt.LocalGraph -optimize annotations (Can.Module home _ _ decls unions aliases _ effects) = - addDecls home annotations decls $ - addEffects home effects $ - addUnions home unions $ - addAliases home aliases $ - Opt.LocalGraph Nothing Map.empty Map.empty - - - --- UNION - - -type Nodes = - Map.Map Opt.Global Opt.Node - - -addUnions :: ModuleName.Canonical -> Map.Map Name.Name Can.Union -> Opt.LocalGraph -> Opt.LocalGraph -addUnions home unions (Opt.LocalGraph main nodes fields) = - Opt.LocalGraph main (Map.foldr (addUnion home) nodes unions) fields - - -addUnion :: ModuleName.Canonical -> Can.Union -> Nodes -> Nodes -addUnion home (Can.Union _ ctors _ opts) nodes = - List.foldl' (addCtorNode home opts) nodes ctors - - -addCtorNode :: ModuleName.Canonical -> Can.CtorOpts -> Nodes -> Can.Ctor -> Nodes -addCtorNode home opts nodes (Can.Ctor name index numArgs _) = - let - node = - case opts of - Can.Normal -> Opt.Ctor index numArgs - Can.Unbox -> Opt.Box - Can.Enum -> Opt.Enum index - in - Map.insert (Opt.Global home name) node nodes - - - --- ALIAS - - -addAliases :: ModuleName.Canonical -> Map.Map Name.Name Can.Alias -> Opt.LocalGraph -> Opt.LocalGraph -addAliases home aliases graph = - Map.foldrWithKey (addAlias home) graph aliases - - -addAlias :: ModuleName.Canonical -> Name.Name -> Can.Alias -> Opt.LocalGraph -> Opt.LocalGraph -addAlias home name (Can.Alias _ tipe) graph@(Opt.LocalGraph main nodes fieldCounts) = - case tipe of - Can.TRecord fields Nothing -> - let - function = - Opt.Function (map fst (Can.fieldsToList fields)) $ Opt.Record $ - Map.mapWithKey (\field _ -> Opt.VarLocal field) fields - - node = - Opt.Define function Set.empty - in - Opt.LocalGraph - main - (Map.insert (Opt.Global home name) node nodes) - (Map.foldrWithKey addRecordCtorField fieldCounts fields) - - _ -> - graph - - -addRecordCtorField :: Name.Name -> Can.FieldType -> Map.Map Name.Name Int -> Map.Map Name.Name Int -addRecordCtorField name _ fields = - Map.insertWith (+) name 1 fields - - - --- ADD EFFECTS - - -addEffects :: ModuleName.Canonical -> Can.Effects -> Opt.LocalGraph -> Opt.LocalGraph -addEffects home effects graph@(Opt.LocalGraph main nodes fields) = - case effects of - Can.NoEffects -> - graph - - Can.Ports ports -> - Map.foldrWithKey (addPort home) graph ports - - Can.Manager _ _ _ manager -> - let - fx = Opt.Global home "$fx$" - cmd = Opt.Global home "command" - sub = Opt.Global home "subscription" - link = Opt.Link fx - newNodes = - case manager of - Can.Cmd _ -> - Map.insert cmd link $ - Map.insert fx (Opt.Manager Opt.Cmd) nodes - - Can.Sub _ -> - Map.insert sub link $ - Map.insert fx (Opt.Manager Opt.Sub) nodes - - Can.Fx _ _ -> - Map.insert cmd link $ - Map.insert sub link $ - Map.insert fx (Opt.Manager Opt.Fx) nodes - in - Opt.LocalGraph main newNodes fields - - -addPort :: ModuleName.Canonical -> Name.Name -> Can.Port -> Opt.LocalGraph -> Opt.LocalGraph -addPort home name port_ graph = - case port_ of - Can.Incoming _ payloadType _ -> - let - (deps, fields, decoder) = Names.run (Port.toDecoder payloadType) - node = Opt.PortIncoming decoder deps - in - addToGraph (Opt.Global home name) node fields graph - - Can.Outgoing _ payloadType _ -> - let - (deps, fields, encoder) = Names.run (Port.toEncoder payloadType) - node = Opt.PortOutgoing encoder deps - in - addToGraph (Opt.Global home name) node fields graph - - - --- HELPER - - -addToGraph :: Opt.Global -> Opt.Node -> Map.Map Name.Name Int -> Opt.LocalGraph -> Opt.LocalGraph -addToGraph name node fields (Opt.LocalGraph main nodes fieldCounts) = - Opt.LocalGraph - main - (Map.insert name node nodes) - (Map.unionWith (+) fields fieldCounts) - - - --- ADD DECLS - - -addDecls :: ModuleName.Canonical -> Annotations -> Can.Decls -> Opt.LocalGraph -> Result i [W.Warning] Opt.LocalGraph -addDecls home annotations decls graph = - case decls of - Can.Declare def subDecls -> - addDecls home annotations subDecls =<< addDef home annotations def graph - - Can.DeclareRec d ds subDecls -> - let defs = d:ds in - case findMain defs of - Nothing -> - addDecls home annotations subDecls (addRecDefs home defs graph) - - Just region -> - Result.throw $ E.BadCycle region (defToName d) (map defToName ds) - - Can.SaveTheEnvironment -> - Result.ok graph - - -findMain :: [Can.Def] -> Maybe A.Region -findMain defs = - case defs of - [] -> - Nothing - - def:rest -> - case def of - Can.Def (A.At region name) _ _ -> - if name == Name._main then Just region else findMain rest - - Can.TypedDef (A.At region name) _ _ _ _ -> - if name == Name._main then Just region else findMain rest - - -defToName :: Can.Def -> Name.Name -defToName def = - case def of - Can.Def (A.At _ name) _ _ -> name - Can.TypedDef (A.At _ name) _ _ _ _ -> name - - - --- ADD DEFS - - -addDef :: ModuleName.Canonical -> Annotations -> Can.Def -> Opt.LocalGraph -> Result i [W.Warning] Opt.LocalGraph -addDef home annotations def graph = - case def of - Can.Def (A.At region name) args body -> - do let (Can.Forall _ tipe) = annotations ! name - Result.warn $ W.MissingTypeAnnotation region name tipe - addDefHelp region annotations home name args body graph - - Can.TypedDef (A.At region name) _ typedArgs body _ -> - addDefHelp region annotations home name (map fst typedArgs) body graph - - -addDefHelp :: A.Region -> Annotations -> ModuleName.Canonical -> Name.Name -> [Can.Pattern] -> Can.Expr -> Opt.LocalGraph -> Result i w Opt.LocalGraph -addDefHelp region annotations home name args body graph@(Opt.LocalGraph _ nodes fieldCounts) = - if name /= Name._main then - Result.ok (addDefNode home name args body Set.empty graph) - else - let - (Can.Forall _ tipe) = annotations ! name - - addMain (deps, fields, main) = - addDefNode home name args body deps $ - Opt.LocalGraph (Just main) nodes (Map.unionWith (+) fields fieldCounts) - in - case Type.deepDealias tipe of - Can.TType hm nm [_] | hm == ModuleName.virtualDom && nm == Name.node -> - Result.ok $ addMain $ Names.run $ - Names.registerKernel Name.virtualDom Opt.Static - - Can.TType hm nm [flags, _, message] | hm == ModuleName.platform && nm == Name.program -> - case Effects.checkPayload flags of - Right () -> - Result.ok $ addMain $ Names.run $ - Opt.Dynamic message <$> Port.toFlagsDecoder flags - - Left (subType, invalidPayload) -> - Result.throw (E.BadFlags region subType invalidPayload) - - _ -> - Result.throw (E.BadType region tipe) - - -addDefNode :: ModuleName.Canonical -> Name.Name -> [Can.Pattern] -> Can.Expr -> Set.Set Opt.Global -> Opt.LocalGraph -> Opt.LocalGraph -addDefNode home name args body mainDeps graph = - let - (deps, fields, def) = - Names.run $ - case args of - [] -> - Expr.optimize Set.empty body - - _ -> - do (argNames, destructors) <- Expr.destructArgs args - obody <- Expr.optimize Set.empty body - pure $ Opt.Function argNames $ - foldr Opt.Destruct obody destructors - in - addToGraph (Opt.Global home name) (Opt.Define def (Set.union deps mainDeps)) fields graph - - - --- ADD RECURSIVE DEFS - - -data State = - State - { _values :: [(Name.Name, Opt.Expr)] - , _functions :: [Opt.Def] - } - - -addRecDefs :: ModuleName.Canonical -> [Can.Def] -> Opt.LocalGraph -> Opt.LocalGraph -addRecDefs home defs (Opt.LocalGraph main nodes fieldCounts) = - let - names = reverse (map toName defs) - cycleName = Opt.Global home (Name.fromManyNames names) - cycle = foldr addValueName Set.empty defs - links = foldr (addLink home (Opt.Link cycleName)) Map.empty defs - - (deps, fields, State values funcs) = - Names.run $ - foldM (addRecDef cycle) (State [] []) defs - in - Opt.LocalGraph - main - (Map.insert cycleName (Opt.Cycle names values funcs deps) (Map.union links nodes)) - (Map.unionWith (+) fields fieldCounts) - - -toName :: Can.Def -> Name.Name -toName def = - case def of - Can.Def (A.At _ name) _ _ -> name - Can.TypedDef (A.At _ name) _ _ _ _ -> name - - -addValueName :: Can.Def -> Set.Set Name.Name -> Set.Set Name.Name -addValueName def names = - case def of - Can.Def (A.At _ name) args _ -> if null args then Set.insert name names else names - Can.TypedDef (A.At _ name) _ args _ _ -> if null args then Set.insert name names else names - - -addLink :: ModuleName.Canonical -> Opt.Node -> Can.Def -> Map.Map Opt.Global Opt.Node -> Map.Map Opt.Global Opt.Node -addLink home link def links = - case def of - Can.Def (A.At _ name) _ _ -> - Map.insert (Opt.Global home name) link links - - Can.TypedDef (A.At _ name) _ _ _ _ -> - Map.insert (Opt.Global home name) link links - - - --- ADD RECURSIVE DEFS - - -addRecDef :: Set.Set Name.Name -> State -> Can.Def -> Names.Tracker State -addRecDef cycle state def = - case def of - Can.Def (A.At _ name) args body -> - addRecDefHelp cycle state name args body - - Can.TypedDef (A.At _ name) _ args body _ -> - addRecDefHelp cycle state name (map fst args) body - - -addRecDefHelp :: Set.Set Name.Name -> State -> Name.Name -> [Can.Pattern] -> Can.Expr -> Names.Tracker State -addRecDefHelp cycle (State values funcs) name args body = - case args of - [] -> - do obody <- Expr.optimize cycle body - pure $ State ((name, obody) : values) funcs - - _:_ -> - do odef <- Expr.optimizePotentialTailCall cycle name args body - pure $ State values (odef : funcs) diff --git a/compiler/src/Optimize/Names.hs b/compiler/src/Optimize/Names.hs deleted file mode 100644 index a115b8cfa1..0000000000 --- a/compiler/src/Optimize/Names.hs +++ /dev/null @@ -1,173 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE Rank2Types #-} -module Optimize.Names - ( Tracker - , run - , generate - , registerKernel - , registerGlobal - , registerDebug - , registerCtor - , registerField - , registerFieldDict - , registerFieldList - ) - where - - -import qualified Data.Map as Map -import qualified Data.Name as Name -import qualified Data.Set as Set - -import qualified AST.Canonical as Can -import qualified AST.Optimized as Opt -import qualified Data.Index as Index -import qualified Elm.ModuleName as ModuleName -import qualified Reporting.Annotation as A - - - --- GENERATOR - - -newtype Tracker a = - Tracker ( - forall r. - Int - -> Set.Set Opt.Global - -> Map.Map Name.Name Int - -> (Int -> Set.Set Opt.Global -> Map.Map Name.Name Int -> a -> r) - -> r - ) - - -run :: Tracker a -> (Set.Set Opt.Global, Map.Map Name.Name Int, a) -run (Tracker k) = - k 0 Set.empty Map.empty - (\_uid deps fields value -> (deps, fields, value)) - - -generate :: Tracker Name.Name -generate = - Tracker $ \uid deps fields ok -> - ok (uid + 1) deps fields (Name.fromVarIndex uid) - - -registerKernel :: Name.Name -> a -> Tracker a -registerKernel home value = - Tracker $ \uid deps fields ok -> - ok uid (Set.insert (Opt.toKernelGlobal home) deps) fields value - - -registerGlobal :: ModuleName.Canonical -> Name.Name -> Tracker Opt.Expr -registerGlobal home name = - Tracker $ \uid deps fields ok -> - let global = Opt.Global home name in - ok uid (Set.insert global deps) fields (Opt.VarGlobal global) - - -registerDebug :: Name.Name -> ModuleName.Canonical -> A.Region -> Tracker Opt.Expr -registerDebug name home region = - Tracker $ \uid deps fields ok -> - let global = Opt.Global ModuleName.debug name in - ok uid (Set.insert global deps) fields (Opt.VarDebug name home region Nothing) - - -registerCtor :: ModuleName.Canonical -> Name.Name -> Index.ZeroBased -> Can.CtorOpts -> Tracker Opt.Expr -registerCtor home name index opts = - Tracker $ \uid deps fields ok -> - let - global = Opt.Global home name - newDeps = Set.insert global deps - in - case opts of - Can.Normal -> - ok uid newDeps fields (Opt.VarGlobal global) - - Can.Enum -> - ok uid newDeps fields $ - case name of - "True" | home == ModuleName.basics -> Opt.Bool True - "False" | home == ModuleName.basics -> Opt.Bool False - _ -> Opt.VarEnum global index - - Can.Unbox -> - ok uid (Set.insert identity newDeps) fields (Opt.VarBox global) - - -identity :: Opt.Global -identity = - Opt.Global ModuleName.basics Name.identity - - -registerField :: Name.Name -> a -> Tracker a -registerField name value = - Tracker $ \uid d fields ok -> - ok uid d (Map.insertWith (+) name 1 fields) value - - -registerFieldDict :: Map.Map Name.Name v -> a -> Tracker a -registerFieldDict newFields value = - Tracker $ \uid d fields ok -> - ok uid d (Map.unionWith (+) fields (Map.map toOne newFields)) value - - -toOne :: a -> Int -toOne _ = 1 - - -registerFieldList :: [Name.Name] -> a -> Tracker a -registerFieldList names value = - Tracker $ \uid deps fields ok -> - ok uid deps (foldr addOne fields names) value - - -addOne :: Name.Name -> Map.Map Name.Name Int -> Map.Map Name.Name Int -addOne name fields = - Map.insertWith (+) name 1 fields - - - --- INSTANCES - - -instance Functor Tracker where - fmap func (Tracker kv) = - Tracker $ \n d f ok -> - let - ok1 n1 d1 f1 value = - ok n1 d1 f1 (func value) - in - kv n d f ok1 - - -instance Applicative Tracker where - {-# INLINE pure #-} - pure value = - Tracker $ \n d f ok -> ok n d f value - - (<*>) (Tracker kf) (Tracker kv) = - Tracker $ \n d f ok -> - let - ok1 n1 d1 f1 func = - let - ok2 n2 d2 f2 value = - ok n2 d2 f2 (func value) - in - kv n1 d1 f1 ok2 - in - kf n d f ok1 - - -instance Monad Tracker where - return = pure - - (>>=) (Tracker k) callback = - Tracker $ \n d f ok -> - let - ok1 n1 d1 f1 a = - case callback a of - Tracker kb -> kb n1 d1 f1 ok - in - k n d f ok1 diff --git a/compiler/src/Optimize/Port.hs b/compiler/src/Optimize/Port.hs deleted file mode 100644 index 5426db91e9..0000000000 --- a/compiler/src/Optimize/Port.hs +++ /dev/null @@ -1,327 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE OverloadedStrings #-} -module Optimize.Port - ( toEncoder - , toFlagsDecoder - , toDecoder - ) - where - - -import Prelude hiding (maybe, null) -import Control.Monad (foldM) -import qualified Data.Map as Map -import qualified Data.Name as Name - -import qualified AST.Canonical as Can -import qualified AST.Optimized as Opt -import qualified AST.Utils.Type as Type -import qualified Data.Index as Index -import qualified Elm.ModuleName as ModuleName -import qualified Optimize.Names as Names - - - --- ENCODE - - -toEncoder :: Can.Type -> Names.Tracker Opt.Expr -toEncoder tipe = - case tipe of - Can.TAlias _ _ args alias -> - toEncoder (Type.dealias args alias) - - Can.TLambda _ _ -> - error "toEncoder: function" - - Can.TVar _ -> - error "toEncoder: type variable" - - Can.TUnit -> - Opt.Function [Name.dollar] <$> encode "null" - - Can.TTuple a b c -> - encodeTuple a b c - - Can.TType _ name args -> - case args of - [] - | name == Name.float -> encode "float" - | name == Name.int -> encode "int" - | name == Name.bool -> encode "bool" - | name == Name.string -> encode "string" - | name == Name.value -> Names.registerGlobal ModuleName.basics Name.identity - - [arg] - | name == Name.maybe -> encodeMaybe arg - | name == Name.list -> encodeList arg - | name == Name.array -> encodeArray arg - - _ -> - error "toEncoder: bad custom type" - - Can.TRecord _ (Just _) -> - error "toEncoder: bad record" - - Can.TRecord fields Nothing -> - let - encodeField (name, Can.FieldType _ fieldType) = - do encoder <- toEncoder fieldType - let value = Opt.Call encoder [Opt.Access (Opt.VarLocal Name.dollar) name] - return $ Opt.Tuple (Opt.Str (Name.toElmString name)) value Nothing - in - do object <- encode "object" - keyValuePairs <- traverse encodeField (Map.toList fields) - Names.registerFieldDict fields $ - Opt.Function [Name.dollar] (Opt.Call object [Opt.List keyValuePairs]) - - - --- ENCODE HELPERS - - -encodeMaybe :: Can.Type -> Names.Tracker Opt.Expr -encodeMaybe tipe = - do null <- encode "null" - encoder <- toEncoder tipe - destruct <- Names.registerGlobal ModuleName.maybe "destruct" - return $ Opt.Function [Name.dollar] $ - Opt.Call destruct [ null, encoder, Opt.VarLocal Name.dollar ] - - -encodeList :: Can.Type -> Names.Tracker Opt.Expr -encodeList tipe = - do list <- encode "list" - encoder <- toEncoder tipe - return $ Opt.Call list [ encoder ] - - -encodeArray :: Can.Type -> Names.Tracker Opt.Expr -encodeArray tipe = - do array <- encode "array" - encoder <- toEncoder tipe - return $ Opt.Call array [ encoder ] - - -encodeTuple :: Can.Type -> Can.Type -> Maybe Can.Type -> Names.Tracker Opt.Expr -encodeTuple a b maybeC = - let - let_ arg index body = - Opt.Destruct (Opt.Destructor arg (Opt.Index index (Opt.Root Name.dollar))) body - - encodeArg arg tipe = - do encoder <- toEncoder tipe - return $ Opt.Call encoder [ Opt.VarLocal arg ] - in - do list <- encode "list" - identity <- Names.registerGlobal ModuleName.basics Name.identity - arg1 <- encodeArg "a" a - arg2 <- encodeArg "b" b - - case maybeC of - Nothing -> - return $ Opt.Function [Name.dollar] $ - let_ "a" Index.first $ - let_ "b" Index.second $ - Opt.Call list [ identity, Opt.List [ arg1, arg2 ] ] - - Just c -> - do arg3 <- encodeArg "c" c - return $ Opt.Function [Name.dollar] $ - let_ "a" Index.first $ - let_ "b" Index.second $ - let_ "c" Index.third $ - Opt.Call list [ identity, Opt.List [ arg1, arg2, arg3 ] ] - - - --- FLAGS DECODER - - -toFlagsDecoder :: Can.Type -> Names.Tracker Opt.Expr -toFlagsDecoder tipe = - case tipe of - Can.TUnit -> - do succeed <- decode "succeed" - return $ Opt.Call succeed [ Opt.Unit ] - - _ -> - toDecoder tipe - - - --- DECODE - - -toDecoder :: Can.Type -> Names.Tracker Opt.Expr -toDecoder tipe = - case tipe of - Can.TLambda _ _ -> - error "functions should not be allowed through input ports" - - Can.TVar _ -> - error "type variables should not be allowed through input ports" - - Can.TAlias _ _ args alias -> - toDecoder (Type.dealias args alias) - - Can.TUnit -> - decodeTuple0 - - Can.TTuple a b c -> - decodeTuple a b c - - Can.TType _ name args -> - case args of - [] - | name == Name.float -> decode "float" - | name == Name.int -> decode "int" - | name == Name.bool -> decode "bool" - | name == Name.string -> decode "string" - | name == Name.value -> decode "value" - - [arg] - | name == Name.maybe -> decodeMaybe arg - | name == Name.list -> decodeList arg - | name == Name.array -> decodeArray arg - - _ -> - error "toDecoder: bad type" - - Can.TRecord _ (Just _) -> - error "toDecoder: bad record" - - Can.TRecord fields Nothing -> - decodeRecord fields - - - --- DECODE MAYBE - - -decodeMaybe :: Can.Type -> Names.Tracker Opt.Expr -decodeMaybe tipe = - do nothing <- Names.registerGlobal ModuleName.maybe "Nothing" - just <- Names.registerGlobal ModuleName.maybe "Just" - - oneOf <- decode "oneOf" - null <- decode "null" - map_ <- decode "map" - - subDecoder <- toDecoder tipe - - return $ - Opt.Call oneOf - [ Opt.List - [ Opt.Call null [ nothing ] - , Opt.Call map_ [ just, subDecoder ] - ] - ] - - --- DECODE LIST - - -decodeList :: Can.Type -> Names.Tracker Opt.Expr -decodeList tipe = - do list <- decode "list" - decoder <- toDecoder tipe - return $ Opt.Call list [ decoder ] - - - --- DECODE ARRAY - - -decodeArray :: Can.Type -> Names.Tracker Opt.Expr -decodeArray tipe = - do array <- decode "array" - decoder <- toDecoder tipe - return $ Opt.Call array [ decoder ] - - - --- DECODE TUPLES - - -decodeTuple0 :: Names.Tracker Opt.Expr -decodeTuple0 = - do null <- decode "null" - return (Opt.Call null [ Opt.Unit ]) - - -decodeTuple :: Can.Type -> Can.Type -> Maybe Can.Type -> Names.Tracker Opt.Expr -decodeTuple a b maybeC = - do succeed <- decode "succeed" - case maybeC of - Nothing -> - let tuple = Opt.Tuple (toLocal 0) (toLocal 1) Nothing in - indexAndThen 0 a =<< - indexAndThen 1 b (Opt.Call succeed [tuple]) - - Just c -> - let tuple = Opt.Tuple (toLocal 0) (toLocal 1) (Just (toLocal 2)) in - indexAndThen 0 a =<< - indexAndThen 1 b =<< - indexAndThen 2 c (Opt.Call succeed [tuple]) - - -toLocal :: Int -> Opt.Expr -toLocal index = - Opt.VarLocal (Name.fromVarIndex index) - - -indexAndThen :: Int -> Can.Type -> Opt.Expr -> Names.Tracker Opt.Expr -indexAndThen i tipe decoder = - do andThen <- decode "andThen" - index <- decode "index" - typeDecoder <- toDecoder tipe - return $ - Opt.Call andThen - [ Opt.Function [Name.fromVarIndex i] decoder - , Opt.Call index [ Opt.Int i, typeDecoder ] - ] - - - --- DECODE RECORDS - - -decodeRecord :: Map.Map Name.Name Can.FieldType -> Names.Tracker Opt.Expr -decodeRecord fields = - let - toFieldExpr name _ = - Opt.VarLocal name - - record = - Opt.Record (Map.mapWithKey toFieldExpr fields) - in - do succeed <- decode "succeed" - foldM fieldAndThen (Opt.Call succeed [record]) =<< - Names.registerFieldDict fields (Map.toList fields) - - -fieldAndThen :: Opt.Expr -> (Name.Name, Can.FieldType) -> Names.Tracker Opt.Expr -fieldAndThen decoder (key, Can.FieldType _ tipe) = - do andThen <- decode "andThen" - field <- decode "field" - typeDecoder <- toDecoder tipe - return $ - Opt.Call andThen - [ Opt.Function [key] decoder - , Opt.Call field [ Opt.Str (Name.toElmString key), typeDecoder ] - ] - - - --- GLOBALS HELPERS - - -encode :: Name.Name -> Names.Tracker Opt.Expr -encode name = - Names.registerGlobal ModuleName.jsonEncode name - - -decode :: Name.Name -> Names.Tracker Opt.Expr -decode name = - Names.registerGlobal ModuleName.jsonDecode name diff --git a/compiler/src/Parse/Declaration.hs b/compiler/src/Parse/Declaration.hs deleted file mode 100644 index d7d3d6d867..0000000000 --- a/compiler/src/Parse/Declaration.hs +++ /dev/null @@ -1,266 +0,0 @@ -{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-} -{-# LANGUAGE OverloadedStrings #-} -module Parse.Declaration - ( Decl(..) - , declaration - , infix_ - ) - where - - -import qualified Data.Name as Name - -import qualified AST.Source as Src -import qualified AST.Utils.Binop as Binop -import qualified Parse.Expression as Expr -import qualified Parse.Pattern as Pattern -import qualified Parse.Keyword as Keyword -import qualified Parse.Number as Number -import qualified Parse.Space as Space -import qualified Parse.Symbol as Symbol -import qualified Parse.Type as Type -import qualified Parse.Variable as Var -import Parse.Primitives hiding (State) -import qualified Parse.Primitives as P -import qualified Reporting.Annotation as A -import qualified Reporting.Error.Syntax as E - - - --- DECLARATION - - -data Decl - = Value (Maybe Src.Comment) (A.Located Src.Value) - | Union (Maybe Src.Comment) (A.Located Src.Union) - | Alias (Maybe Src.Comment) (A.Located Src.Alias) - | Port (Maybe Src.Comment) Src.Port - - -declaration :: Space.Parser E.Decl Decl -declaration = - do maybeDocs <- chompDocComment - start <- getPosition - oneOf E.DeclStart - [ typeDecl maybeDocs start - , portDecl maybeDocs - , valueDecl maybeDocs start - ] - - - --- DOC COMMENT - - -chompDocComment :: Parser E.Decl (Maybe Src.Comment) -chompDocComment = - oneOfWithFallback - [ - do docComment <- Space.docComment E.DeclStart E.DeclSpace - Space.chomp E.DeclSpace - Space.checkFreshLine E.DeclFreshLineAfterDocComment - return (Just docComment) - ] - Nothing - - - --- DEFINITION and ANNOTATION - - -{-# INLINE valueDecl #-} -valueDecl :: Maybe Src.Comment -> A.Position -> Space.Parser E.Decl Decl -valueDecl maybeDocs start = - do name <- Var.lower E.DeclStart - end <- getPosition - specialize (E.DeclDef name) $ - do Space.chompAndCheckIndent E.DeclDefSpace E.DeclDefIndentEquals - oneOf E.DeclDefEquals - [ - do word1 0x3A {-:-} E.DeclDefEquals - Space.chompAndCheckIndent E.DeclDefSpace E.DeclDefIndentType - (tipe, _) <- specialize E.DeclDefType Type.expression - Space.checkFreshLine E.DeclDefNameRepeat - defName <- chompMatchingName name - Space.chompAndCheckIndent E.DeclDefSpace E.DeclDefIndentEquals - chompDefArgsAndBody maybeDocs start defName (Just tipe) [] - , - chompDefArgsAndBody maybeDocs start (A.at start end name) Nothing [] - ] - - -chompDefArgsAndBody :: Maybe Src.Comment -> A.Position -> A.Located Name.Name -> Maybe Src.Type -> [Src.Pattern] -> Space.Parser E.DeclDef Decl -chompDefArgsAndBody maybeDocs start name tipe revArgs = - oneOf E.DeclDefEquals - [ do arg <- specialize E.DeclDefArg Pattern.term - Space.chompAndCheckIndent E.DeclDefSpace E.DeclDefIndentEquals - chompDefArgsAndBody maybeDocs start name tipe (arg : revArgs) - , do word1 0x3D {-=-} E.DeclDefEquals - Space.chompAndCheckIndent E.DeclDefSpace E.DeclDefIndentBody - (body, end) <- specialize E.DeclDefBody Expr.expression - let value = Src.Value name (reverse revArgs) body tipe - let avalue = A.at start end value - return (Value maybeDocs avalue, end) - ] - - -chompMatchingName :: Name.Name -> Parser E.DeclDef (A.Located Name.Name) -chompMatchingName expectedName = - let - (P.Parser parserL) = Var.lower E.DeclDefNameRepeat - in - P.Parser $ \state@(P.State _ _ _ _ sr sc) cok eok cerr eerr -> - let - cokL name newState@(P.State _ _ _ _ er ec) = - if expectedName == name - then cok (A.At (A.Region (A.Position sr sc) (A.Position er ec)) name) newState - else cerr sr sc (E.DeclDefNameMatch name) - - eokL name newState@(P.State _ _ _ _ er ec) = - if expectedName == name - then eok (A.At (A.Region (A.Position sr sc) (A.Position er ec)) name) newState - else eerr sr sc (E.DeclDefNameMatch name) - in - parserL state cokL eokL cerr eerr - - - --- TYPE DECLARATIONS - - -{-# INLINE typeDecl #-} -typeDecl :: Maybe Src.Comment -> A.Position -> Space.Parser E.Decl Decl -typeDecl maybeDocs start = - inContext E.DeclType (Keyword.type_ E.DeclStart) $ - do Space.chompAndCheckIndent E.DT_Space E.DT_IndentName - oneOf E.DT_Name - [ - inContext E.DT_Alias (Keyword.alias_ E.DT_Name) $ - do Space.chompAndCheckIndent E.AliasSpace E.AliasIndentEquals - (name, args) <- chompAliasNameToEquals - (tipe, end) <- specialize E.AliasBody Type.expression - let alias = A.at start end (Src.Alias name args tipe) - return (Alias maybeDocs alias, end) - , - specialize E.DT_Union $ - do (name, args) <- chompCustomNameToEquals - (firstVariant, firstEnd) <- Type.variant - (variants, end) <- chompVariants [firstVariant] firstEnd - let union = A.at start end (Src.Union name args variants) - return (Union maybeDocs union, end) - ] - - - --- TYPE ALIASES - - -chompAliasNameToEquals :: Parser E.TypeAlias (A.Located Name.Name, [A.Located Name.Name]) -chompAliasNameToEquals = - do name <- addLocation (Var.upper E.AliasName) - Space.chompAndCheckIndent E.AliasSpace E.AliasIndentEquals - chompAliasNameToEqualsHelp name [] - - -chompAliasNameToEqualsHelp :: A.Located Name.Name -> [A.Located Name.Name] -> Parser E.TypeAlias (A.Located Name.Name, [A.Located Name.Name]) -chompAliasNameToEqualsHelp name args = - oneOf E.AliasEquals - [ do arg <- addLocation (Var.lower E.AliasEquals) - Space.chompAndCheckIndent E.AliasSpace E.AliasIndentEquals - chompAliasNameToEqualsHelp name (arg:args) - , do word1 0x3D {-=-} E.AliasEquals - Space.chompAndCheckIndent E.AliasSpace E.AliasIndentBody - return ( name, reverse args ) - ] - - - --- CUSTOM TYPES - - -chompCustomNameToEquals :: Parser E.CustomType (A.Located Name.Name, [A.Located Name.Name]) -chompCustomNameToEquals = - do name <- addLocation (Var.upper E.CT_Name) - Space.chompAndCheckIndent E.CT_Space E.CT_IndentEquals - chompCustomNameToEqualsHelp name [] - - -chompCustomNameToEqualsHelp :: A.Located Name.Name -> [A.Located Name.Name] -> Parser E.CustomType (A.Located Name.Name, [A.Located Name.Name]) -chompCustomNameToEqualsHelp name args = - oneOf E.CT_Equals - [ do arg <- addLocation (Var.lower E.CT_Equals) - Space.chompAndCheckIndent E.CT_Space E.CT_IndentEquals - chompCustomNameToEqualsHelp name (arg:args) - , do word1 0x3D {-=-} E.CT_Equals - Space.chompAndCheckIndent E.CT_Space E.CT_IndentAfterEquals - return ( name, reverse args ) - ] - - -chompVariants :: [(A.Located Name.Name, [Src.Type])] -> A.Position -> Space.Parser E.CustomType [(A.Located Name.Name, [Src.Type])] -chompVariants variants end = - oneOfWithFallback - [ do Space.checkIndent end E.CT_IndentBar - word1 0x7C {-|-} E.CT_Bar - Space.chompAndCheckIndent E.CT_Space E.CT_IndentAfterBar - (variant, newEnd) <- Type.variant - chompVariants (variant:variants) newEnd - ] - (reverse variants, end) - - - --- PORT - - -{-# INLINE portDecl #-} -portDecl :: Maybe Src.Comment -> Space.Parser E.Decl Decl -portDecl maybeDocs = - inContext E.Port (Keyword.port_ E.DeclStart) $ - do Space.chompAndCheckIndent E.PortSpace E.PortIndentName - name <- addLocation (Var.lower E.PortName) - Space.chompAndCheckIndent E.PortSpace E.PortIndentColon - word1 0x3A {-:-} E.PortColon - Space.chompAndCheckIndent E.PortSpace E.PortIndentType - (tipe, end) <- specialize E.PortType Type.expression - return - ( Port maybeDocs (Src.Port name tipe) - , end - ) - - - --- INFIX - - --- INVARIANT: always chomps to a freshline --- -infix_ :: Parser E.Module (A.Located Src.Infix) -infix_ = - let - err = E.Infix - _err = \_ -> E.Infix - in - do start <- getPosition - Keyword.infix_ err - Space.chompAndCheckIndent _err err - associativity <- - oneOf err - [ Keyword.left_ err >> return Binop.Left - , Keyword.right_ err >> return Binop.Right - , Keyword.non_ err >> return Binop.Non - ] - Space.chompAndCheckIndent _err err - precedence <- Number.precedence err - Space.chompAndCheckIndent _err err - word1 0x28 {-(-} err - op <- Symbol.operator err _err - word1 0x29 {-)-} err - Space.chompAndCheckIndent _err err - word1 0x3D {-=-} err - Space.chompAndCheckIndent _err err - name <- Var.lower err - end <- getPosition - Space.chomp _err - Space.checkFreshLine err - return (A.at start end (Src.Infix op associativity precedence name)) diff --git a/compiler/src/Parse/Expression.hs b/compiler/src/Parse/Expression.hs deleted file mode 100644 index 64ad4f6d34..0000000000 --- a/compiler/src/Parse/Expression.hs +++ /dev/null @@ -1,577 +0,0 @@ -{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-} -{-# LANGUAGE OverloadedStrings #-} -module Parse.Expression - ( expression - ) - where - - -import qualified Data.Name as Name - -import qualified AST.Source as Src -import qualified Parse.Keyword as Keyword -import qualified Parse.Number as Number -import qualified Parse.Pattern as Pattern -import qualified Parse.Shader as Shader -import qualified Parse.Space as Space -import qualified Parse.Symbol as Symbol -import qualified Parse.Type as Type -import qualified Parse.String as String -import qualified Parse.Variable as Var -import Parse.Primitives hiding (State) -import qualified Parse.Primitives as P -import qualified Reporting.Annotation as A -import qualified Reporting.Error.Syntax as E - - - --- TERMS - - -term :: Parser E.Expr Src.Expr -term = - do start <- getPosition - oneOf E.Start - [ variable start >>= accessible start - , string start - , number start - , Shader.shader start - , list start - , record start >>= accessible start - , tuple start >>= accessible start - , accessor start - , character start - ] - - -string :: A.Position -> Parser E.Expr Src.Expr -string start = - do str <- String.string E.Start E.String - addEnd start (Src.Str str) - - -character :: A.Position -> Parser E.Expr Src.Expr -character start = - do chr <- String.character E.Start E.Char - addEnd start (Src.Chr chr) - - -number :: A.Position -> Parser E.Expr Src.Expr -number start = - do nmbr <- Number.number E.Start E.Number - addEnd start $ - case nmbr of - Number.Int int -> Src.Int int - Number.Float float -> Src.Float float - - -accessor :: A.Position -> Parser E.Expr Src.Expr -accessor start = - do word1 0x2E {-.-} E.Dot - field <- Var.lower E.Access - addEnd start (Src.Accessor field) - - -variable :: A.Position -> Parser E.Expr Src.Expr -variable start = - do var <- Var.foreignAlpha E.Start - addEnd start var - - -accessible :: A.Position -> Src.Expr -> Parser E.Expr Src.Expr -accessible start expr = - oneOfWithFallback - [ do word1 0x2E {-.-} E.Dot - pos <- getPosition - field <- Var.lower E.Access - end <- getPosition - accessible start $ - A.at start end (Src.Access expr (A.at pos end field)) - ] - expr - - - --- LISTS - - -list :: A.Position -> Parser E.Expr Src.Expr -list start = - inContext E.List (word1 0x5B {-[-} E.Start) $ - do Space.chompAndCheckIndent E.ListSpace E.ListIndentOpen - oneOf E.ListOpen - [ do (entry, end) <- specialize E.ListExpr expression - Space.checkIndent end E.ListIndentEnd - chompListEnd start [entry] - , do word1 0x5D {-]-} E.ListOpen - addEnd start (Src.List []) - ] - - -chompListEnd :: A.Position -> [Src.Expr] -> Parser E.List Src.Expr -chompListEnd start entries = - oneOf E.ListEnd - [ do word1 0x2C {-,-} E.ListEnd - Space.chompAndCheckIndent E.ListSpace E.ListIndentExpr - (entry, end) <- specialize E.ListExpr expression - Space.checkIndent end E.ListIndentEnd - chompListEnd start (entry:entries) - , do word1 0x5D {-]-} E.ListEnd - addEnd start (Src.List (reverse entries)) - ] - - - --- TUPLES - - -tuple :: A.Position -> Parser E.Expr Src.Expr -tuple start@(A.Position row col) = - inContext E.Tuple (word1 0x28 {-(-} E.Start) $ - do before <- getPosition - Space.chompAndCheckIndent E.TupleSpace E.TupleIndentExpr1 - after <- getPosition - if before /= after - then - do (entry, end) <- specialize E.TupleExpr expression - Space.checkIndent end E.TupleIndentEnd - chompTupleEnd start entry [] - else - oneOf E.TupleIndentExpr1 - [ - do op <- Symbol.operator E.TupleIndentExpr1 E.TupleOperatorReserved - if op == "-" - then - oneOf E.TupleOperatorClose - [ - do word1 0x29 {-)-} E.TupleOperatorClose - addEnd start (Src.Op op) - , - do (entry, end) <- - specialize E.TupleExpr $ - do negatedExpr@(A.At (A.Region _ end) _) <- term - Space.chomp E.Space - let exprStart = A.Position row (col + 2) - let expr = A.at exprStart end (Src.Negate negatedExpr) - chompExprEnd exprStart (State [] expr [] end) - Space.checkIndent end E.TupleIndentEnd - chompTupleEnd start entry [] - ] - else - do word1 0x29 {-)-} E.TupleOperatorClose - addEnd start (Src.Op op) - , - do word1 0x29 {-)-} E.TupleIndentExpr1 - addEnd start Src.Unit - , - do (entry, end) <- specialize E.TupleExpr expression - Space.checkIndent end E.TupleIndentEnd - chompTupleEnd start entry [] - ] - - -chompTupleEnd :: A.Position -> Src.Expr -> [Src.Expr] -> Parser E.Tuple Src.Expr -chompTupleEnd start firstExpr revExprs = - oneOf E.TupleEnd - [ do word1 0x2C {-,-} E.TupleEnd - Space.chompAndCheckIndent E.TupleSpace E.TupleIndentExprN - (entry, end) <- specialize E.TupleExpr expression - Space.checkIndent end E.TupleIndentEnd - chompTupleEnd start firstExpr (entry : revExprs) - , do word1 0x29 {-)-} E.TupleEnd - case reverse revExprs of - [] -> - return firstExpr - - secondExpr : otherExprs -> - addEnd start (Src.Tuple firstExpr secondExpr otherExprs) - ] - - - --- RECORDS - - -record :: A.Position -> Parser E.Expr Src.Expr -record start = - inContext E.Record (word1 0x7B {- { -} E.Start) $ - do Space.chompAndCheckIndent E.RecordSpace E.RecordIndentOpen - oneOf E.RecordOpen - [ do word1 0x7D {-}-} E.RecordOpen - addEnd start (Src.Record []) - , do starter <- addLocation (Var.lower E.RecordField) - Space.chompAndCheckIndent E.RecordSpace E.RecordIndentEquals - oneOf E.RecordEquals - [ do word1 0x7C {-|-} E.RecordEquals - Space.chompAndCheckIndent E.RecordSpace E.RecordIndentField - firstField <- chompField - fields <- chompFields [firstField] - addEnd start (Src.Update starter fields) - , do word1 0x3D {-=-} E.RecordEquals - Space.chompAndCheckIndent E.RecordSpace E.RecordIndentExpr - (value, end) <- specialize E.RecordExpr expression - Space.checkIndent end E.RecordIndentEnd - fields <- chompFields [(starter, value)] - addEnd start (Src.Record fields) - ] - ] - - -type Field = ( A.Located Name.Name, Src.Expr ) - - -chompFields :: [Field] -> Parser E.Record [Field] -chompFields fields = - oneOf E.RecordEnd - [ do word1 0x2C {-,-} E.RecordEnd - Space.chompAndCheckIndent E.RecordSpace E.RecordIndentField - f <- chompField - chompFields (f : fields) - , do word1 0x7D {-}-} E.RecordEnd - return (reverse fields) - ] - - -chompField :: Parser E.Record Field -chompField = - do key <- addLocation (Var.lower E.RecordField) - Space.chompAndCheckIndent E.RecordSpace E.RecordIndentEquals - word1 0x3D {-=-} E.RecordEquals - Space.chompAndCheckIndent E.RecordSpace E.RecordIndentExpr - (value, end) <- specialize E.RecordExpr expression - Space.checkIndent end E.RecordIndentEnd - return (key, value) - - - --- EXPRESSIONS - - -expression :: Space.Parser E.Expr Src.Expr -expression = - do start <- getPosition - oneOf E.Start - [ let_ start - , if_ start - , case_ start - , function start - , do expr <- possiblyNegativeTerm start - end <- getPosition - Space.chomp E.Space - chompExprEnd start (State [] expr [] end) - ] - - -data State = - State - { _ops :: ![(Src.Expr, A.Located Name.Name)] - , _expr :: !Src.Expr - , _args :: ![Src.Expr] - , _end :: !A.Position - } - - -chompExprEnd :: A.Position -> State -> Space.Parser E.Expr Src.Expr -chompExprEnd start (State ops expr args end) = - oneOfWithFallback - [ -- argument - do Space.checkIndent end E.Start - arg <- term - newEnd <- getPosition - Space.chomp E.Space - chompExprEnd start (State ops expr (arg:args) newEnd) - - , -- operator - do Space.checkIndent end E.Start - op@(A.At (A.Region opStart opEnd) opName) <- addLocation (Symbol.operator E.Start E.OperatorReserved) - Space.chompAndCheckIndent E.Space (E.IndentOperatorRight opName) - newStart <- getPosition - if "-" == opName && end /= opStart && opEnd == newStart - then - -- negative terms - do negatedExpr <- term - newEnd <- getPosition - Space.chomp E.Space - let arg = A.at opStart newEnd (Src.Negate negatedExpr) - chompExprEnd start (State ops expr (arg:args) newEnd) - else - let err = E.OperatorRight opName in - oneOf err - [ -- term - do newExpr <- possiblyNegativeTerm newStart - newEnd <- getPosition - Space.chomp E.Space - let newOps = (toCall expr args, op) : ops - chompExprEnd start (State newOps newExpr [] newEnd) - - , -- final term - do (newLast, newEnd) <- - oneOf err - [ let_ newStart - , case_ newStart - , if_ newStart - , function newStart - ] - let newOps = (toCall expr args, op) : ops - let finalExpr = Src.Binops (reverse newOps) newLast - return ( A.at start newEnd finalExpr, newEnd ) - ] - - ] - -- done - ( - case ops of - [] -> - ( toCall expr args - , end - ) - - _ -> - ( A.at start end (Src.Binops (reverse ops) (toCall expr args)) - , end - ) - ) - - -possiblyNegativeTerm :: A.Position -> Parser E.Expr Src.Expr -possiblyNegativeTerm start = - oneOf E.Start - [ do word1 0x2D {---} E.Start - expr <- term - addEnd start (Src.Negate expr) - , term - ] - - -toCall :: Src.Expr -> [Src.Expr] -> Src.Expr -toCall func revArgs = - case revArgs of - [] -> - func - - lastArg : _ -> - A.merge func lastArg (Src.Call func (reverse revArgs)) - - - --- IF EXPRESSION - - -if_ :: A.Position -> Space.Parser E.Expr Src.Expr -if_ start = - inContext E.If (Keyword.if_ E.Start) $ - chompIfEnd start [] - - -chompIfEnd :: A.Position -> [(Src.Expr, Src.Expr)] -> Space.Parser E.If Src.Expr -chompIfEnd start branches = - do Space.chompAndCheckIndent E.IfSpace E.IfIndentCondition - (condition, condEnd) <- specialize E.IfCondition expression - Space.checkIndent condEnd E.IfIndentThen - Keyword.then_ E.IfThen - Space.chompAndCheckIndent E.IfSpace E.IfIndentThenBranch - (thenBranch, thenEnd) <- specialize E.IfThenBranch expression - Space.checkIndent thenEnd E.IfIndentElse - Keyword.else_ E.IfElse - Space.chompAndCheckIndent E.IfSpace E.IfIndentElseBranch - let newBranches = (condition, thenBranch) : branches - oneOf E.IfElseBranchStart - [ - do Keyword.if_ E.IfElseBranchStart - chompIfEnd start newBranches - , - do (elseBranch, elseEnd) <- specialize E.IfElseBranch expression - let ifExpr = Src.If (reverse newBranches) elseBranch - return ( A.at start elseEnd ifExpr, elseEnd ) - ] - - - --- LAMBDA EXPRESSION - - -function :: A.Position -> Space.Parser E.Expr Src.Expr -function start = - inContext E.Func (word1 0x5C {-\-} E.Start) $ - do Space.chompAndCheckIndent E.FuncSpace E.FuncIndentArg - arg <- specialize E.FuncArg Pattern.term - Space.chompAndCheckIndent E.FuncSpace E.FuncIndentArrow - revArgs <- chompArgs [arg] - Space.chompAndCheckIndent E.FuncSpace E.FuncIndentBody - (body, end) <- specialize E.FuncBody expression - let funcExpr = Src.Lambda (reverse revArgs) body - return (A.at start end funcExpr, end) - - -chompArgs :: [Src.Pattern] -> Parser E.Func [Src.Pattern] -chompArgs revArgs = - oneOf E.FuncArrow - [ do arg <- specialize E.FuncArg Pattern.term - Space.chompAndCheckIndent E.FuncSpace E.FuncIndentArrow - chompArgs (arg:revArgs) - , do word2 0x2D 0x3E {-->-} E.FuncArrow - return revArgs - ] - - - --- CASE EXPRESSIONS - - -case_ :: A.Position -> Space.Parser E.Expr Src.Expr -case_ start = - inContext E.Case (Keyword.case_ E.Start) $ - do Space.chompAndCheckIndent E.CaseSpace E.CaseIndentExpr - (expr, exprEnd) <- specialize E.CaseExpr expression - Space.checkIndent exprEnd E.CaseIndentOf - Keyword.of_ E.CaseOf - Space.chompAndCheckIndent E.CaseSpace E.CaseIndentPattern - withIndent $ - do (firstBranch, firstEnd) <- chompBranch - (branches, end) <- chompCaseEnd [firstBranch] firstEnd - return - ( A.at start end (Src.Case expr branches) - , end - ) - - -chompBranch :: Space.Parser E.Case (Src.Pattern, Src.Expr) -chompBranch = - do (pattern, patternEnd) <- specialize E.CasePattern Pattern.expression - Space.checkIndent patternEnd E.CaseIndentArrow - word2 0x2D 0x3E {-->-} E.CaseArrow - Space.chompAndCheckIndent E.CaseSpace E.CaseIndentBranch - (branchExpr, end) <- specialize E.CaseBranch expression - return ( (pattern, branchExpr), end ) - - -chompCaseEnd :: [(Src.Pattern, Src.Expr)] -> A.Position -> Space.Parser E.Case [(Src.Pattern, Src.Expr)] -chompCaseEnd branches end = - oneOfWithFallback - [ do Space.checkAligned E.CasePatternAlignment - (branch, newEnd) <- chompBranch - chompCaseEnd (branch:branches) newEnd - ] - (reverse branches, end) - - - --- LET EXPRESSION - - -let_ :: A.Position -> Space.Parser E.Expr Src.Expr -let_ start = - inContext E.Let (Keyword.let_ E.Start) $ - do (defs, defsEnd) <- - withBacksetIndent 3 $ - do Space.chompAndCheckIndent E.LetSpace E.LetIndentDef - withIndent $ - do (def, end) <- chompLetDef - chompLetDefs [def] end - - Space.checkIndent defsEnd E.LetIndentIn - Keyword.in_ E.LetIn - Space.chompAndCheckIndent E.LetSpace E.LetIndentBody - (body, end) <- specialize E.LetBody expression - return - ( A.at start end (Src.Let defs body) - , end - ) - - -chompLetDefs :: [A.Located Src.Def] -> A.Position -> Space.Parser E.Let [A.Located Src.Def] -chompLetDefs revDefs end = - oneOfWithFallback - [ do Space.checkAligned E.LetDefAlignment - (def, newEnd) <- chompLetDef - chompLetDefs (def:revDefs) newEnd - ] - (reverse revDefs, end) - - - --- LET DEFINITIONS - - -chompLetDef :: Space.Parser E.Let (A.Located Src.Def) -chompLetDef = - oneOf E.LetDefName - [ definition - , destructure - ] - - - --- DEFINITION - - -definition :: Space.Parser E.Let (A.Located Src.Def) -definition = - do aname@(A.At (A.Region start _) name) <- addLocation (Var.lower E.LetDefName) - specialize (E.LetDef name) $ - do Space.chompAndCheckIndent E.DefSpace E.DefIndentEquals - oneOf E.DefEquals - [ - do word1 0x3A {-:-} E.DefEquals - Space.chompAndCheckIndent E.DefSpace E.DefIndentType - (tipe, _) <- specialize E.DefType Type.expression - Space.checkAligned E.DefAlignment - defName <- chompMatchingName name - Space.chompAndCheckIndent E.DefSpace E.DefIndentEquals - chompDefArgsAndBody start defName (Just tipe) [] - , - chompDefArgsAndBody start aname Nothing [] - ] - - -chompDefArgsAndBody :: A.Position -> A.Located Name.Name -> Maybe Src.Type -> [Src.Pattern] -> Space.Parser E.Def (A.Located Src.Def) -chompDefArgsAndBody start name tipe revArgs = - oneOf E.DefEquals - [ do arg <- specialize E.DefArg Pattern.term - Space.chompAndCheckIndent E.DefSpace E.DefIndentEquals - chompDefArgsAndBody start name tipe (arg : revArgs) - , do word1 0x3D {-=-} E.DefEquals - Space.chompAndCheckIndent E.DefSpace E.DefIndentBody - (body, end) <- specialize E.DefBody expression - return - ( A.at start end (Src.Define name (reverse revArgs) body tipe) - , end - ) - ] - - -chompMatchingName :: Name.Name -> Parser E.Def (A.Located Name.Name) -chompMatchingName expectedName = - let - (P.Parser parserL) = Var.lower E.DefNameRepeat - in - P.Parser $ \state@(P.State _ _ _ _ sr sc) cok eok cerr eerr -> - let - cokL name newState@(P.State _ _ _ _ er ec) = - if expectedName == name - then cok (A.At (A.Region (A.Position sr sc) (A.Position er ec)) name) newState - else cerr sr sc (E.DefNameMatch name) - - eokL name newState@(P.State _ _ _ _ er ec) = - if expectedName == name - then eok (A.At (A.Region (A.Position sr sc) (A.Position er ec)) name) newState - else eerr sr sc (E.DefNameMatch name) - in - parserL state cokL eokL cerr eerr - - - - --- DESTRUCTURE - - -destructure :: Space.Parser E.Let (A.Located Src.Def) -destructure = - specialize E.LetDestruct $ - do start <- getPosition - pattern <- specialize E.DestructPattern Pattern.term - Space.chompAndCheckIndent E.DestructSpace E.DestructIndentEquals - word1 0x3D {-=-} E.DestructEquals - Space.chompAndCheckIndent E.DestructSpace E.DestructIndentBody - (expr, end) <- specialize E.DestructBody expression - return ( A.at start end (Src.Destruct pattern expr), end ) diff --git a/compiler/src/Parse/Keyword.hs b/compiler/src/Parse/Keyword.hs deleted file mode 100644 index 7562b6a165..0000000000 --- a/compiler/src/Parse/Keyword.hs +++ /dev/null @@ -1,265 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE BangPatterns #-} -module Parse.Keyword - ( type_, alias_, port_ - , if_, then_, else_ - , case_, of_ - , let_, in_ - , infix_, left_, right_, non_ - , module_, import_, exposing_, as_ - , effect_, where_, command_, subscription_ - , k4, k5 - ) - where - - -import Foreign.Ptr (plusPtr) -import Data.Word (Word8) - -import Parse.Primitives (Parser, Row, Col) -import qualified Parse.Variable as Var -import qualified Parse.Primitives as P - - - --- DECLARATIONS - - -type_ :: (Row -> Col -> x) -> Parser x () -type_ tx = k4 0x74 0x79 0x70 0x65 tx - -alias_ :: (Row -> Col -> x) -> Parser x () -alias_ tx = k5 0x61 0x6C 0x69 0x61 0x73 tx - -port_ :: (Row -> Col -> x) -> Parser x () -port_ tx = k4 0x70 0x6F 0x72 0x74 tx - - - --- IF EXPRESSIONS - - -if_ :: (Row -> Col -> x) -> Parser x () -if_ tx = k2 0x69 0x66 tx - -then_ :: (Row -> Col -> x) -> Parser x () -then_ tx = k4 0x74 0x68 0x65 0x6E tx - -else_ :: (Row -> Col -> x) -> Parser x () -else_ tx = k4 0x65 0x6C 0x73 0x65 tx - - - --- CASE EXPRESSIONS - - -case_ :: (Row -> Col -> x) -> Parser x () -case_ tx = k4 0x63 0x61 0x73 0x65 tx - -of_ :: (Row -> Col -> x) -> Parser x () -of_ tx = k2 0x6F 0x66 tx - - - --- LET EXPRESSIONS - - -let_ :: (Row -> Col -> x) -> Parser x () -let_ tx = k3 0x6C 0x65 0x74 tx - -in_ :: (Row -> Col -> x) -> Parser x () -in_ tx = k2 0x69 0x6E tx - - - --- INFIXES - - -infix_ :: (Row -> Col -> x) -> Parser x () -infix_ tx = k5 0x69 0x6E 0x66 0x69 0x78 tx - -left_ :: (Row -> Col -> x) -> Parser x () -left_ tx = k4 0x6C 0x65 0x66 0x74 tx - -right_ :: (Row -> Col -> x) -> Parser x () -right_ tx = k5 0x72 0x69 0x67 0x68 0x74 tx - -non_ :: (Row -> Col -> x) -> Parser x () -non_ tx = k3 0x6E 0x6F 0x6E tx - - - --- IMPORTS - - -module_ :: (Row -> Col -> x) -> Parser x () -module_ tx = k6 0x6D 0x6F 0x64 0x75 0x6C 0x65 tx - -import_ :: (Row -> Col -> x) -> Parser x () -import_ tx = k6 0x69 0x6D 0x70 0x6F 0x72 0x74 tx - -exposing_ :: (Row -> Col -> x) -> Parser x () -exposing_ tx = k8 0x65 0x78 0x70 0x6F 0x73 0x69 0x6E 0x67 tx - -as_ :: (Row -> Col -> x) -> Parser x () -as_ tx = k2 0x61 0x73 tx - - - --- EFFECTS - - -effect_ :: (Row -> Col -> x) -> Parser x () -effect_ tx = k6 0x65 0x66 0x66 0x65 0x63 0x74 tx - -where_ :: (Row -> Col -> x) -> Parser x () -where_ tx = k5 0x77 0x68 0x65 0x72 0x65 tx - -command_ :: (Row -> Col -> x) -> Parser x () -command_ tx = k7 0x63 0x6F 0x6D 0x6D 0x61 0x6E 0x64 tx - -subscription_ :: (Row -> Col -> x) -> Parser x () -subscription_ toError = - P.Parser $ \(P.State src pos end indent row col) cok _ _ eerr -> - let !pos12 = plusPtr pos 12 in - if pos12 <= end - && P.unsafeIndex ( pos ) == 0x73 - && P.unsafeIndex (plusPtr pos 1) == 0x75 - && P.unsafeIndex (plusPtr pos 2) == 0x62 - && P.unsafeIndex (plusPtr pos 3) == 0x73 - && P.unsafeIndex (plusPtr pos 4) == 0x63 - && P.unsafeIndex (plusPtr pos 5) == 0x72 - && P.unsafeIndex (plusPtr pos 6) == 0x69 - && P.unsafeIndex (plusPtr pos 7) == 0x70 - && P.unsafeIndex (plusPtr pos 8) == 0x74 - && P.unsafeIndex (plusPtr pos 9) == 0x69 - && P.unsafeIndex (plusPtr pos 10) == 0x6F - && P.unsafeIndex (plusPtr pos 11) == 0x6E - && Var.getInnerWidth pos12 end == 0 - then - let !s = P.State src pos12 end indent row (col + 12) in cok () s - else - eerr row col toError - - - --- KEYWORDS - - -k2 :: Word8 -> Word8 -> (Row -> Col -> x) -> Parser x () -k2 w1 w2 toError = - P.Parser $ \(P.State src pos end indent row col) cok _ _ eerr -> - let !pos2 = plusPtr pos 2 in - if pos2 <= end - && P.unsafeIndex ( pos ) == w1 - && P.unsafeIndex (plusPtr pos 1) == w2 - && Var.getInnerWidth pos2 end == 0 - then - let !s = P.State src pos2 end indent row (col + 2) in cok () s - else - eerr row col toError - - -k3 :: Word8 -> Word8 -> Word8 -> (Row -> Col -> x) -> Parser x () -k3 w1 w2 w3 toError = - P.Parser $ \(P.State src pos end indent row col) cok _ _ eerr -> - let !pos3 = plusPtr pos 3 in - if pos3 <= end - && P.unsafeIndex ( pos ) == w1 - && P.unsafeIndex (plusPtr pos 1) == w2 - && P.unsafeIndex (plusPtr pos 2) == w3 - && Var.getInnerWidth pos3 end == 0 - then - let !s = P.State src pos3 end indent row (col + 3) in cok () s - else - eerr row col toError - - -k4 :: Word8 -> Word8 -> Word8 -> Word8 -> (Row -> Col -> x) -> Parser x () -k4 w1 w2 w3 w4 toError = - P.Parser $ \(P.State src pos end indent row col) cok _ _ eerr -> - let !pos4 = plusPtr pos 4 in - if pos4 <= end - && P.unsafeIndex ( pos ) == w1 - && P.unsafeIndex (plusPtr pos 1) == w2 - && P.unsafeIndex (plusPtr pos 2) == w3 - && P.unsafeIndex (plusPtr pos 3) == w4 - && Var.getInnerWidth pos4 end == 0 - then - let !s = P.State src pos4 end indent row (col + 4) in cok () s - else - eerr row col toError - - -k5 :: Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> (Row -> Col -> x) -> Parser x () -k5 w1 w2 w3 w4 w5 toError = - P.Parser $ \(P.State src pos end indent row col) cok _ _ eerr -> - let !pos5 = plusPtr pos 5 in - if pos5 <= end - && P.unsafeIndex ( pos ) == w1 - && P.unsafeIndex (plusPtr pos 1) == w2 - && P.unsafeIndex (plusPtr pos 2) == w3 - && P.unsafeIndex (plusPtr pos 3) == w4 - && P.unsafeIndex (plusPtr pos 4) == w5 - && Var.getInnerWidth pos5 end == 0 - then - let !s = P.State src pos5 end indent row (col + 5) in cok () s - else - eerr row col toError - - -k6 :: Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> (Row -> Col -> x) -> Parser x () -k6 w1 w2 w3 w4 w5 w6 toError = - P.Parser $ \(P.State src pos end indent row col) cok _ _ eerr -> - let !pos6 = plusPtr pos 6 in - if pos6 <= end - && P.unsafeIndex ( pos ) == w1 - && P.unsafeIndex (plusPtr pos 1) == w2 - && P.unsafeIndex (plusPtr pos 2) == w3 - && P.unsafeIndex (plusPtr pos 3) == w4 - && P.unsafeIndex (plusPtr pos 4) == w5 - && P.unsafeIndex (plusPtr pos 5) == w6 - && Var.getInnerWidth pos6 end == 0 - then - let !s = P.State src pos6 end indent row (col + 6) in cok () s - else - eerr row col toError - - -k7 :: Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> (Row -> Col -> x) -> Parser x () -k7 w1 w2 w3 w4 w5 w6 w7 toError = - P.Parser $ \(P.State src pos end indent row col) cok _ _ eerr -> - let !pos7 = plusPtr pos 7 in - if pos7 <= end - && P.unsafeIndex ( pos ) == w1 - && P.unsafeIndex (plusPtr pos 1) == w2 - && P.unsafeIndex (plusPtr pos 2) == w3 - && P.unsafeIndex (plusPtr pos 3) == w4 - && P.unsafeIndex (plusPtr pos 4) == w5 - && P.unsafeIndex (plusPtr pos 5) == w6 - && P.unsafeIndex (plusPtr pos 6) == w7 - && Var.getInnerWidth pos7 end == 0 - then - let !s = P.State src pos7 end indent row (col + 7) in cok () s - else - eerr row col toError - - -k8 :: Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> (Row -> Col -> x) -> Parser x () -k8 w1 w2 w3 w4 w5 w6 w7 w8 toError = - P.Parser $ \(P.State src pos end indent row col) cok _ _ eerr -> - let !pos8 = plusPtr pos 8 in - if pos8 <= end - && P.unsafeIndex ( pos ) == w1 - && P.unsafeIndex (plusPtr pos 1) == w2 - && P.unsafeIndex (plusPtr pos 2) == w3 - && P.unsafeIndex (plusPtr pos 3) == w4 - && P.unsafeIndex (plusPtr pos 4) == w5 - && P.unsafeIndex (plusPtr pos 5) == w6 - && P.unsafeIndex (plusPtr pos 6) == w7 - && P.unsafeIndex (plusPtr pos 7) == w8 - && Var.getInnerWidth pos8 end == 0 - then - let !s = P.State src pos8 end indent row (col + 8) in cok () s - else - eerr row col toError diff --git a/compiler/src/Parse/Module.hs b/compiler/src/Parse/Module.hs deleted file mode 100644 index 990d6b35f3..0000000000 --- a/compiler/src/Parse/Module.hs +++ /dev/null @@ -1,487 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE OverloadedStrings #-} -module Parse.Module - ( fromByteString - , ProjectType(..) - , isKernel - , chompImports - , chompImport - ) - where - - -import qualified Data.ByteString as BS -import qualified Data.Name as Name - -import qualified AST.Source as Src -import qualified Elm.Compiler.Imports as Imports -import qualified Elm.Package as Pkg -import qualified Parse.Declaration as Decl -import qualified Parse.Keyword as Keyword -import qualified Parse.Space as Space -import qualified Parse.Symbol as Symbol -import qualified Parse.Variable as Var -import qualified Parse.Primitives as P -import Parse.Primitives hiding (State, fromByteString) -import qualified Reporting.Annotation as A -import qualified Reporting.Error.Syntax as E - - - --- FROM BYTE STRING - - -fromByteString :: ProjectType -> BS.ByteString -> Either E.Error Src.Module -fromByteString projectType source = - case P.fromByteString (chompModule projectType) E.ModuleBadEnd source of - Right modul -> checkModule projectType modul - Left err -> Left (E.ParseError err) - - - --- PROJECT TYPE - - -data ProjectType - = Package Pkg.Name - | Application - - -isCore :: ProjectType -> Bool -isCore projectType = - case projectType of - Package pkg -> pkg == Pkg.core - Application -> False - - -isKernel :: ProjectType -> Bool -isKernel projectType = - case projectType of - Package pkg -> Pkg.isKernel pkg - Application -> False - - - --- MODULE - - -data Module = - Module - { _header :: Maybe Header - , _imports :: [Src.Import] - , _infixes :: [A.Located Src.Infix] - , _decls :: [Decl.Decl] - } - - -chompModule :: ProjectType -> Parser E.Module Module -chompModule projectType = - do header <- chompHeader - imports <- chompImports (if isCore projectType then [] else Imports.defaults) - infixes <- if isKernel projectType then chompInfixes [] else return [] - decls <- specialize E.Declarations $ chompDecls [] - return (Module header imports infixes decls) - - - --- CHECK MODULE - - -checkModule :: ProjectType -> Module -> Either E.Error Src.Module -checkModule projectType (Module maybeHeader imports infixes decls) = - let - (values, unions, aliases, ports) = categorizeDecls [] [] [] [] decls - in - case maybeHeader of - Just (Header name effects exports docs) -> - Src.Module (Just name) exports (toDocs docs decls) imports values unions aliases infixes - <$> checkEffects projectType ports effects - - Nothing -> - Right $ - Src.Module Nothing (A.At A.one Src.Open) (Src.NoDocs A.one) imports values unions aliases infixes $ - case ports of - [] -> Src.NoEffects - _:_ -> Src.Ports ports - - -checkEffects :: ProjectType -> [Src.Port] -> Effects -> Either E.Error Src.Effects -checkEffects projectType ports effects = - case effects of - NoEffects region -> - case ports of - [] -> - Right Src.NoEffects - - Src.Port name _ : _ -> - case projectType of - Package _ -> Left (E.NoPortsInPackage name) - Application -> Left (E.UnexpectedPort region) - - Ports region -> - case projectType of - Package _ -> - Left (E.NoPortModulesInPackage region) - - Application -> - case ports of - [] -> Left (E.NoPorts region) - _:_ -> Right (Src.Ports ports) - - Manager region manager -> - if isKernel projectType then - case ports of - [] -> Right (Src.Manager region manager) - _:_ -> Left (E.UnexpectedPort region) - else - Left (E.NoEffectsOutsideKernel region) - - - -categorizeDecls :: [A.Located Src.Value] -> [A.Located Src.Union] -> [A.Located Src.Alias] -> [Src.Port] -> [Decl.Decl] -> ( [A.Located Src.Value], [A.Located Src.Union], [A.Located Src.Alias], [Src.Port] ) -categorizeDecls values unions aliases ports decls = - case decls of - [] -> - (values, unions, aliases, ports) - - decl:otherDecls -> - case decl of - Decl.Value _ value -> categorizeDecls (value:values) unions aliases ports otherDecls - Decl.Union _ union -> categorizeDecls values (union:unions) aliases ports otherDecls - Decl.Alias _ alias -> categorizeDecls values unions (alias:aliases) ports otherDecls - Decl.Port _ port_ -> categorizeDecls values unions aliases (port_:ports) otherDecls - - - --- TO DOCS - - -toDocs :: Either A.Region Src.Comment -> [Decl.Decl] -> Src.Docs -toDocs comment decls = - case comment of - Right overview -> - Src.YesDocs overview (getComments decls []) - - Left region -> - Src.NoDocs region - - -getComments :: [Decl.Decl] -> [(Name.Name,Src.Comment)] -> [(Name.Name,Src.Comment)] -getComments decls comments = - case decls of - [] -> - comments - - decl:otherDecls -> - case decl of - Decl.Value c (A.At _ (Src.Value n _ _ _)) -> getComments otherDecls (addComment c n comments) - Decl.Union c (A.At _ (Src.Union n _ _ )) -> getComments otherDecls (addComment c n comments) - Decl.Alias c (A.At _ (Src.Alias n _ _ )) -> getComments otherDecls (addComment c n comments) - Decl.Port c (Src.Port n _ ) -> getComments otherDecls (addComment c n comments) - - -addComment :: Maybe Src.Comment -> A.Located Name.Name -> [(Name.Name,Src.Comment)] -> [(Name.Name,Src.Comment)] -addComment maybeComment (A.At _ name) comments = - case maybeComment of - Just comment -> (name, comment) : comments - Nothing -> comments - - - --- FRESH LINES - - -freshLine :: (Row -> Col -> E.Module) -> Parser E.Module () -freshLine toFreshLineError = - do Space.chomp E.ModuleSpace - Space.checkFreshLine toFreshLineError - - - --- CHOMP DECLARATIONS - - -chompDecls :: [Decl.Decl] -> Parser E.Decl [Decl.Decl] -chompDecls decls = - do (decl, _) <- Decl.declaration - oneOfWithFallback - [ do Space.checkFreshLine E.DeclStart - chompDecls (decl:decls) - ] - (reverse (decl:decls)) - - -chompInfixes :: [A.Located Src.Infix] -> Parser E.Module [A.Located Src.Infix] -chompInfixes infixes = - oneOfWithFallback - [ do binop <- Decl.infix_ - chompInfixes (binop:infixes) - ] - infixes - - - --- MODULE DOC COMMENT - - -chompModuleDocCommentSpace :: Parser E.Module (Either A.Region Src.Comment) -chompModuleDocCommentSpace = - do (A.At region ()) <- addLocation (freshLine E.FreshLine) - oneOfWithFallback - [ - do docComment <- Space.docComment E.ImportStart E.ModuleSpace - Space.chomp E.ModuleSpace - Space.checkFreshLine E.FreshLine - return (Right docComment) - ] - (Left region) - - - --- HEADER - - -data Header = - Header (A.Located Name.Name) Effects (A.Located Src.Exposing) (Either A.Region Src.Comment) - - -data Effects - = NoEffects A.Region - | Ports A.Region - | Manager A.Region Src.Manager - - -chompHeader :: Parser E.Module (Maybe Header) -chompHeader = - do freshLine E.FreshLine - start <- getPosition - oneOfWithFallback - [ - -- module MyThing exposing (..) - do Keyword.module_ E.ModuleProblem - effectEnd <- getPosition - Space.chompAndCheckIndent E.ModuleSpace E.ModuleProblem - name <- addLocation (Var.moduleName E.ModuleName) - Space.chompAndCheckIndent E.ModuleSpace E.ModuleProblem - Keyword.exposing_ E.ModuleProblem - Space.chompAndCheckIndent E.ModuleSpace E.ModuleProblem - exports <- addLocation (specialize E.ModuleExposing exposing) - comment <- chompModuleDocCommentSpace - return $ Just $ - Header name (NoEffects (A.Region start effectEnd)) exports comment - , - -- port module MyThing exposing (..) - do Keyword.port_ E.PortModuleProblem - Space.chompAndCheckIndent E.ModuleSpace E.PortModuleProblem - Keyword.module_ E.PortModuleProblem - effectEnd <- getPosition - Space.chompAndCheckIndent E.ModuleSpace E.PortModuleProblem - name <- addLocation (Var.moduleName E.PortModuleName) - Space.chompAndCheckIndent E.ModuleSpace E.PortModuleProblem - Keyword.exposing_ E.PortModuleProblem - Space.chompAndCheckIndent E.ModuleSpace E.PortModuleProblem - exports <- addLocation (specialize E.PortModuleExposing exposing) - comment <- chompModuleDocCommentSpace - return $ Just $ - Header name (Ports (A.Region start effectEnd)) exports comment - , - -- effect module MyThing where { command = MyCmd } exposing (..) - do Keyword.effect_ E.Effect - Space.chompAndCheckIndent E.ModuleSpace E.Effect - Keyword.module_ E.Effect - effectEnd <- getPosition - Space.chompAndCheckIndent E.ModuleSpace E.Effect - name <- addLocation (Var.moduleName E.ModuleName) - Space.chompAndCheckIndent E.ModuleSpace E.Effect - Keyword.where_ E.Effect - Space.chompAndCheckIndent E.ModuleSpace E.Effect - manager <- chompManager - Space.chompAndCheckIndent E.ModuleSpace E.Effect - Keyword.exposing_ E.Effect - Space.chompAndCheckIndent E.ModuleSpace E.Effect - exports <- addLocation (specialize (const E.Effect) exposing) - comment <- chompModuleDocCommentSpace - return $ Just $ - Header name (Manager (A.Region start effectEnd) manager) exports comment - ] - -- default header - Nothing - - -chompManager :: Parser E.Module Src.Manager -chompManager = - do word1 0x7B {- { -} E.Effect - spaces_em - oneOf E.Effect - [ do cmd <- chompCommand - spaces_em - oneOf E.Effect - [ do word1 0x7D {-}-} E.Effect - spaces_em - return (Src.Cmd cmd) - , do word1 0x2C {-,-} E.Effect - spaces_em - sub <- chompSubscription - spaces_em - word1 0x7D {-}-} E.Effect - spaces_em - return (Src.Fx cmd sub) - ] - , do sub <- chompSubscription - spaces_em - oneOf E.Effect - [ do word1 0x7D {-}-} E.Effect - spaces_em - return (Src.Sub sub) - , do word1 0x2C {-,-} E.Effect - spaces_em - cmd <- chompCommand - spaces_em - word1 0x7D {-}-} E.Effect - spaces_em - return (Src.Fx cmd sub) - ] - ] - - -chompCommand :: Parser E.Module (A.Located Name.Name) -chompCommand = - do Keyword.command_ E.Effect - spaces_em - word1 0x3D {-=-} E.Effect - spaces_em - addLocation (Var.upper E.Effect) - - -chompSubscription :: Parser E.Module (A.Located Name.Name) -chompSubscription = - do Keyword.subscription_ E.Effect - spaces_em - word1 0x3D {-=-} E.Effect - spaces_em - addLocation (Var.upper E.Effect) - - -spaces_em :: Parser E.Module () -spaces_em = - Space.chompAndCheckIndent E.ModuleSpace E.Effect - - - --- IMPORTS - - -chompImports :: [Src.Import] -> Parser E.Module [Src.Import] -chompImports is = - oneOfWithFallback - [ do i <- chompImport - chompImports (i:is) - ] - (reverse is) - - -chompImport :: Parser E.Module Src.Import -chompImport = - do Keyword.import_ E.ImportStart - Space.chompAndCheckIndent E.ModuleSpace E.ImportIndentName - name@(A.At (A.Region _ end) _) <- addLocation (Var.moduleName E.ImportName) - Space.chomp E.ModuleSpace - oneOf E.ImportEnd - [ do Space.checkFreshLine E.ImportEnd - return $ Src.Import name Nothing (Src.Explicit []) - , do Space.checkIndent end E.ImportEnd - oneOf E.ImportAs - [ chompAs name - , chompExposing name Nothing - ] - ] - - -chompAs :: A.Located Name.Name -> Parser E.Module Src.Import -chompAs name = - do Keyword.as_ E.ImportAs - Space.chompAndCheckIndent E.ModuleSpace E.ImportIndentAlias - alias <- Var.upper E.ImportAlias - end <- getPosition - Space.chomp E.ModuleSpace - oneOf E.ImportEnd - [ do Space.checkFreshLine E.ImportEnd - return $ Src.Import name (Just alias) (Src.Explicit []) - , do Space.checkIndent end E.ImportEnd - chompExposing name (Just alias) - ] - - -chompExposing :: A.Located Name.Name -> Maybe Name.Name -> Parser E.Module Src.Import -chompExposing name maybeAlias = - do Keyword.exposing_ E.ImportExposing - Space.chompAndCheckIndent E.ModuleSpace E.ImportIndentExposingList - exposed <- specialize E.ImportExposingList exposing - freshLine E.ImportEnd - return $ Src.Import name maybeAlias exposed - - - --- LISTING - - -exposing :: Parser E.Exposing Src.Exposing -exposing = - do word1 0x28 {-(-} E.ExposingStart - Space.chompAndCheckIndent E.ExposingSpace E.ExposingIndentValue - oneOf E.ExposingValue - [ do word2 0x2E 0x2E {-..-} E.ExposingValue - Space.chompAndCheckIndent E.ExposingSpace E.ExposingIndentEnd - word1 0x29 {-)-} E.ExposingEnd - return Src.Open - , do exposed <- chompExposed - Space.chompAndCheckIndent E.ExposingSpace E.ExposingIndentEnd - exposingHelp [exposed] - ] - - -exposingHelp :: [Src.Exposed] -> Parser E.Exposing Src.Exposing -exposingHelp revExposed = - oneOf E.ExposingEnd - [ do word1 0x2C {-,-} E.ExposingEnd - Space.chompAndCheckIndent E.ExposingSpace E.ExposingIndentValue - exposed <- chompExposed - Space.chompAndCheckIndent E.ExposingSpace E.ExposingIndentEnd - exposingHelp (exposed:revExposed) - , do word1 0x29 {-)-} E.ExposingEnd - return (Src.Explicit (reverse revExposed)) - ] - - -chompExposed :: Parser E.Exposing Src.Exposed -chompExposed = - do start <- getPosition - oneOf E.ExposingValue - [ do name <- Var.lower E.ExposingValue - end <- getPosition - return $ Src.Lower $ A.at start end name - , do word1 0x28 {-(-} E.ExposingValue - op <- Symbol.operator E.ExposingOperator E.ExposingOperatorReserved - word1 0x29 {-)-} E.ExposingOperatorRightParen - end <- getPosition - return $ Src.Operator (A.Region start end) op - , do name <- Var.upper E.ExposingValue - end <- getPosition - Space.chompAndCheckIndent E.ExposingSpace E.ExposingIndentEnd - Src.Upper (A.at start end name) <$> privacy - ] - - -privacy :: Parser E.Exposing Src.Privacy -privacy = - oneOfWithFallback - [ do word1 0x28 {-(-} E.ExposingTypePrivacy - Space.chompAndCheckIndent E.ExposingSpace E.ExposingTypePrivacy - start <- getPosition - word2 0x2E 0x2E {-..-} E.ExposingTypePrivacy - end <- getPosition - Space.chompAndCheckIndent E.ExposingSpace E.ExposingTypePrivacy - word1 0x29 {-)-} E.ExposingTypePrivacy - return $ Src.Public (A.Region start end) - ] - Src.Private diff --git a/compiler/src/Parse/Number.hs b/compiler/src/Parse/Number.hs deleted file mode 100644 index 107853d07a..0000000000 --- a/compiler/src/Parse/Number.hs +++ /dev/null @@ -1,305 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE BangPatterns, UnboxedTuples #-} -module Parse.Number - ( Number(..) - , number - , Outcome(..) - , chompInt - , chompHex - , precedence - ) - where - - -import Data.Word (Word8) -import Foreign.Ptr (Ptr, plusPtr, minusPtr) - -import qualified AST.Utils.Binop as Binop -import qualified Elm.Float as EF -import Parse.Primitives (Parser, Row, Col) -import qualified Parse.Variable as Var -import qualified Parse.Primitives as P -import qualified Reporting.Error.Syntax as E - - - --- HELPERS - - -isDirtyEnd :: Ptr Word8 -> Ptr Word8 -> Word8 -> Bool -isDirtyEnd pos end word = - Var.getInnerWidthHelp pos end word > 0 - - -{-# INLINE isDecimalDigit #-} -isDecimalDigit :: Word8 -> Bool -isDecimalDigit word = - word <= 0x39 {-9-} && word >= 0x30 {-0-} - - - --- NUMBERS - - -data Number - = Int Int - | Float EF.Float - - -number :: (Row -> Col -> x) -> (E.Number -> Row -> Col -> x) -> Parser x Number -number toExpectation toError = - P.Parser $ \(P.State src pos end indent row col) cok _ cerr eerr -> - if pos >= end then - eerr row col toExpectation - - else - let !word = P.unsafeIndex pos in - if not (isDecimalDigit word) then - eerr row col toExpectation - - else - let - outcome = - if word == 0x30 {-0-} then - chompZero (plusPtr pos 1) end - else - chompInt (plusPtr pos 1) end (fromIntegral (word - 0x30 {-0-})) - in - case outcome of - Err newPos problem -> - let - !newCol = col + fromIntegral (minusPtr newPos pos) - in - cerr row newCol (toError problem) - - OkInt newPos n -> - let - !newCol = col + fromIntegral (minusPtr newPos pos) - !integer = Int n - !newState = P.State src newPos end indent row newCol - in - cok integer newState - - OkFloat newPos -> - let - !newCol = col + fromIntegral (minusPtr newPos pos) - !copy = EF.fromPtr pos newPos - !float = Float copy - !newState = P.State src newPos end indent row newCol - in - cok float newState - - - --- CHOMP OUTCOME - - --- first Int is newPos --- -data Outcome - = Err (Ptr Word8) E.Number - | OkInt (Ptr Word8) Int - | OkFloat (Ptr Word8) - - - --- CHOMP INT - - -chompInt :: Ptr Word8 -> Ptr Word8 -> Int -> Outcome -chompInt !pos end !n = - if pos >= end then - - OkInt pos n - - else - - let - !word = P.unsafeIndex pos - in - if isDecimalDigit word then - chompInt (plusPtr pos 1) end (10 * n + fromIntegral (word - 0x30 {-0-})) - - else if word == 0x2E {-.-} then - chompFraction pos end n - - else if word == 0x65 {-e-} || word == 0x45 {-E-} then - chompExponent (plusPtr pos 1) end - - else if isDirtyEnd pos end word then - Err pos E.NumberEnd - - else - OkInt pos n - - - --- CHOMP FRACTION - - -chompFraction :: Ptr Word8 -> Ptr Word8 -> Int -> Outcome -chompFraction pos end n = - let - !pos1 = plusPtr pos 1 - in - if pos1 >= end then - Err pos (E.NumberDot n) - - else if isDecimalDigit (P.unsafeIndex pos1) then - chompFractionHelp (plusPtr pos1 1) end - - else - Err pos (E.NumberDot n) - - -chompFractionHelp :: Ptr Word8 -> Ptr Word8 -> Outcome -chompFractionHelp pos end = - if pos >= end then - OkFloat pos - - else - let !word = P.unsafeIndex pos in - if isDecimalDigit word then - chompFractionHelp (plusPtr pos 1) end - - else if word == 0x65 {-e-} || word == 0x45 {-E-} then - chompExponent (plusPtr pos 1) end - - else if isDirtyEnd pos end word then - Err pos E.NumberEnd - - else - OkFloat pos - - - --- CHOMP EXPONENT - - -chompExponent :: Ptr Word8 -> Ptr Word8 -> Outcome -chompExponent pos end = - if pos >= end then - Err pos E.NumberEnd - - else - let !word = P.unsafeIndex pos in - if isDecimalDigit word then - chompExponentHelp (plusPtr pos 1) end - - else if word == 0x2B {-+-} || word == 0x2D {---} then - - let !pos1 = plusPtr pos 1 in - if pos1 < end && isDecimalDigit (P.unsafeIndex pos1) then - chompExponentHelp (plusPtr pos 2) end - else - Err pos E.NumberEnd - - else - Err pos E.NumberEnd - - -chompExponentHelp :: Ptr Word8 -> Ptr Word8 -> Outcome -chompExponentHelp pos end = - if pos >= end then - OkFloat pos - - else if isDecimalDigit (P.unsafeIndex pos) then - chompExponentHelp (plusPtr pos 1) end - - else - OkFloat pos - - - --- CHOMP ZERO - - -chompZero :: Ptr Word8 -> Ptr Word8 -> Outcome -chompZero pos end = - if pos >= end then - OkInt pos 0 - - else - let !word = P.unsafeIndex pos in - if word == 0x78 {-x-} then - chompHexInt (plusPtr pos 1) end - - else if word == 0x2E {-.-} then - chompFraction pos end 0 - - else if isDecimalDigit word then - Err pos E.NumberNoLeadingZero - - else if isDirtyEnd pos end word then - Err pos E.NumberEnd - - else - OkInt pos 0 - - -chompHexInt :: Ptr Word8 -> Ptr Word8 -> Outcome -chompHexInt pos end = - let (# newPos, answer #) = chompHex pos end in - if answer < 0 then - Err newPos E.NumberHexDigit - else - OkInt newPos answer - - - --- CHOMP HEX - - --- Return -1 if it has NO digits --- Return -2 if it has BAD digits - -{-# INLINE chompHex #-} -chompHex :: Ptr Word8 -> Ptr Word8 -> (# Ptr Word8, Int #) -chompHex pos end = - chompHexHelp pos end (-1) 0 - - -chompHexHelp :: Ptr Word8 -> Ptr Word8 -> Int -> Int -> (# Ptr Word8, Int #) -chompHexHelp pos end answer accumulator = - if pos >= end then - (# pos, answer #) - else - let - !newAnswer = - stepHex pos end (P.unsafeIndex pos) accumulator - in - if newAnswer < 0 then - (# pos, if newAnswer == -1 then answer else -2 #) - else - chompHexHelp (plusPtr pos 1) end newAnswer newAnswer - - -{-# INLINE stepHex #-} -stepHex :: Ptr Word8 -> Ptr Word8 -> Word8 -> Int -> Int -stepHex pos end word acc - | 0x30 {-0-} <= word && word <= 0x39 {-9-} = 16 * acc + fromIntegral (word - 0x30 {-0-}) - | 0x61 {-a-} <= word && word <= 0x66 {-f-} = 16 * acc + 10 + fromIntegral (word - 0x61 {-a-}) - | 0x41 {-A-} <= word && word <= 0x46 {-F-} = 16 * acc + 10 + fromIntegral (word - 0x41 {-A-}) - | isDirtyEnd pos end word = -2 - | True = -1 - - - --- PRECEDENCE - - -precedence :: (Row -> Col -> x) -> Parser x Binop.Precedence -precedence toExpectation = - P.Parser $ \(P.State src pos end indent row col) cok _ _ eerr -> - if pos >= end then - eerr row col toExpectation - - else - let !word = P.unsafeIndex pos in - if isDecimalDigit word then - cok - (Binop.Precedence (fromIntegral (word - 0x30 {-0-}))) - (P.State src (plusPtr pos 1) end indent row (col + 1)) - - else - eerr row col toExpectation diff --git a/compiler/src/Parse/Pattern.hs b/compiler/src/Parse/Pattern.hs deleted file mode 100644 index 8bd13cb4ec..0000000000 --- a/compiler/src/Parse/Pattern.hs +++ /dev/null @@ -1,279 +0,0 @@ -{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-} -{-# LANGUAGE BangPatterns, UnboxedTuples, OverloadedStrings #-} -module Parse.Pattern - ( term - , expression - ) - where - - -import qualified Data.List as List -import qualified Data.Name as Name -import qualified Data.Utf8 as Utf8 -import Foreign.Ptr (plusPtr) - -import qualified AST.Source as Src -import qualified Parse.Keyword as Keyword -import qualified Parse.Number as Number -import qualified Parse.Space as Space -import qualified Parse.String as String -import qualified Parse.Variable as Var -import qualified Parse.Primitives as P -import Parse.Primitives (Parser, addLocation, addEnd, getPosition, inContext, oneOf, oneOfWithFallback, word1, word2) -import qualified Reporting.Annotation as A -import qualified Reporting.Error.Syntax as E - - - --- TERM - - -term :: Parser E.Pattern Src.Pattern -term = - do start <- getPosition - oneOf E.PStart - [ record start - , tuple start - , list start - , termHelp start - ] - - -termHelp :: A.Position -> Parser E.Pattern Src.Pattern -termHelp start = - oneOf E.PStart - [ - do wildcard - addEnd start Src.PAnything - , - do name <- Var.lower E.PStart - addEnd start (Src.PVar name) - , - do upper <- Var.foreignUpper E.PStart - end <- getPosition - let region = A.Region start end - return $ A.at start end $ - case upper of - Var.Unqualified name -> - Src.PCtor region name [] - - Var.Qualified home name -> - Src.PCtorQual region home name [] - , - do number <- Number.number E.PStart E.PNumber - end <- getPosition - case number of - Number.Int int -> - return (A.at start end (Src.PInt int)) - - Number.Float float -> - P.Parser $ \(P.State _ _ _ _ row col) _ _ cerr _ -> - let - width = fromIntegral (Utf8.size float) - in - cerr row (col - width) (E.PFloat width) - , - do str <- String.string E.PStart E.PString - addEnd start (Src.PStr str) - , - do chr <- String.character E.PStart E.PChar - addEnd start (Src.PChr chr) - ] - - - --- WILDCARD - - -wildcard :: Parser E.Pattern () -wildcard = - P.Parser $ \(P.State src pos end indent row col) cok _ cerr eerr -> - if pos == end || P.unsafeIndex pos /= 0x5F {- _ -} then - eerr row col E.PStart - else - let - !newPos = plusPtr pos 1 - !newCol = col + 1 - in - if Var.getInnerWidth newPos end > 0 then - let (# badPos, badCol #) = Var.chompInnerChars newPos end newCol in - cerr row col (E.PWildcardNotVar (Name.fromPtr pos badPos) (fromIntegral (badCol - col))) - else - let !newState = P.State src newPos end indent row newCol in - cok () newState - - - --- RECORDS - - -record :: A.Position -> Parser E.Pattern Src.Pattern -record start = - inContext E.PRecord (word1 0x7B {- { -} E.PStart) $ - do Space.chompAndCheckIndent E.PRecordSpace E.PRecordIndentOpen - oneOf E.PRecordOpen - [ do var <- addLocation (Var.lower E.PRecordField) - Space.chompAndCheckIndent E.PRecordSpace E.PRecordIndentEnd - recordHelp start [var] - , do word1 0x7D {-}-} E.PRecordEnd - addEnd start (Src.PRecord []) - ] - - -recordHelp :: A.Position -> [A.Located Name.Name] -> Parser E.PRecord Src.Pattern -recordHelp start vars = - oneOf E.PRecordEnd - [ do word1 0x2C {-,-} E.PRecordEnd - Space.chompAndCheckIndent E.PRecordSpace E.PRecordIndentField - var <- addLocation (Var.lower E.PRecordField) - Space.chompAndCheckIndent E.PRecordSpace E.PRecordIndentEnd - recordHelp start (var:vars) - , do word1 0x7D {-}-} E.PRecordEnd - addEnd start (Src.PRecord vars) - ] - - - --- TUPLES - - -tuple :: A.Position -> Parser E.Pattern Src.Pattern -tuple start = - inContext E.PTuple (word1 0x28 {-(-} E.PStart) $ - do Space.chompAndCheckIndent E.PTupleSpace E.PTupleIndentExpr1 - oneOf E.PTupleOpen - [ do (pattern, end) <- P.specialize E.PTupleExpr expression - Space.checkIndent end E.PTupleIndentEnd - tupleHelp start pattern [] - , do word1 0x29 {-)-} E.PTupleEnd - addEnd start Src.PUnit - ] - - -tupleHelp :: A.Position -> Src.Pattern -> [Src.Pattern] -> Parser E.PTuple Src.Pattern -tupleHelp start firstPattern revPatterns = - oneOf E.PTupleEnd - [ do word1 0x2C {-,-} E.PTupleEnd - Space.chompAndCheckIndent E.PTupleSpace E.PTupleIndentExprN - (pattern, end) <- P.specialize E.PTupleExpr expression - Space.checkIndent end E.PTupleIndentEnd - tupleHelp start firstPattern (pattern : revPatterns) - , do word1 0x29 {-)-} E.PTupleEnd - case reverse revPatterns of - [] -> - return firstPattern - - secondPattern : otherPatterns -> - addEnd start (Src.PTuple firstPattern secondPattern otherPatterns) - ] - - - --- LIST - - -list :: A.Position -> Parser E.Pattern Src.Pattern -list start = - inContext E.PList (word1 0x5B {-[-} E.PStart) $ - do Space.chompAndCheckIndent E.PListSpace E.PListIndentOpen - oneOf E.PListOpen - [ do (pattern, end) <- P.specialize E.PListExpr expression - Space.checkIndent end E.PListIndentEnd - listHelp start [pattern] - , do word1 0x5D {-]-} E.PListEnd - addEnd start (Src.PList []) - ] - - -listHelp :: A.Position -> [Src.Pattern] -> Parser E.PList Src.Pattern -listHelp start patterns = - oneOf E.PListEnd - [ do word1 0x2C {-,-} E.PListEnd - Space.chompAndCheckIndent E.PListSpace E.PListIndentExpr - (pattern, end) <- P.specialize E.PListExpr expression - Space.checkIndent end E.PListIndentEnd - listHelp start (pattern:patterns) - , do word1 0x5D {-]-} E.PListEnd - addEnd start (Src.PList (reverse patterns)) - ] - - - --- EXPRESSION - - -expression :: Space.Parser E.Pattern Src.Pattern -expression = - do start <- getPosition - ePart <- exprPart - exprHelp start [] ePart - - -exprHelp :: A.Position -> [Src.Pattern] -> (Src.Pattern, A.Position) -> Space.Parser E.Pattern Src.Pattern -exprHelp start revPatterns (pattern, end) = - oneOfWithFallback - [ do Space.checkIndent end E.PIndentStart - word2 0x3A 0x3A {-::-} E.PStart - Space.chompAndCheckIndent E.PSpace E.PIndentStart - ePart <- exprPart - exprHelp start (pattern:revPatterns) ePart - , do Space.checkIndent end E.PIndentStart - Keyword.as_ E.PStart - Space.chompAndCheckIndent E.PSpace E.PIndentAlias - nameStart <- getPosition - name <- Var.lower E.PAlias - newEnd <- getPosition - Space.chomp E.PSpace - let alias = A.at nameStart newEnd name - return - ( A.at start newEnd (Src.PAlias (List.foldl' cons pattern revPatterns) alias) - , newEnd - ) - ] - ( List.foldl' cons pattern revPatterns - , end - ) - - -cons :: Src.Pattern -> Src.Pattern -> Src.Pattern -cons tl hd = - A.merge hd tl (Src.PCons hd tl) - - - --- EXPRESSION PART - - -exprPart :: Space.Parser E.Pattern Src.Pattern -exprPart = - oneOf E.PStart - [ - do start <- getPosition - upper <- Var.foreignUpper E.PStart - end <- getPosition - exprTermHelp (A.Region start end) upper start [] - , - do eterm@(A.At (A.Region _ end) _) <- term - Space.chomp E.PSpace - return (eterm, end) - ] - - -exprTermHelp :: A.Region -> Var.Upper -> A.Position -> [Src.Pattern] -> Space.Parser E.Pattern Src.Pattern -exprTermHelp region upper start revArgs = - do end <- getPosition - Space.chomp E.PSpace - oneOfWithFallback - [ do Space.checkIndent end E.PIndentStart - arg <- term - exprTermHelp region upper start (arg:revArgs) - ] - ( A.at start end $ - case upper of - Var.Unqualified name -> - Src.PCtor region name (reverse revArgs) - - Var.Qualified home name -> - Src.PCtorQual region home name (reverse revArgs) - , end - ) diff --git a/compiler/src/Parse/Primitives.hs b/compiler/src/Parse/Primitives.hs deleted file mode 100644 index bb9731935d..0000000000 --- a/compiler/src/Parse/Primitives.hs +++ /dev/null @@ -1,404 +0,0 @@ -{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind -fno-warn-name-shadowing #-} -{-# LANGUAGE BangPatterns, Rank2Types, UnboxedTuples #-} -module Parse.Primitives - ( fromByteString - , Parser(..) - , State(..) - , Row - , Col - , oneOf, oneOfWithFallback - , inContext, specialize - , getPosition, getCol, addLocation, addEnd - , getIndent, setIndent, withIndent, withBacksetIndent - , word1, word2 - , unsafeIndex, isWord, getCharWidth - , Snippet(..) - , fromSnippet - ) - where - - -import Prelude hiding (length) -import qualified Control.Applicative as Applicative (Applicative(..)) -import qualified Data.ByteString.Internal as B -import Data.Word (Word8, Word16) -import Foreign.Ptr (Ptr, plusPtr) -import Foreign.Storable (peek) -import Foreign.ForeignPtr (ForeignPtr, touchForeignPtr) -import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr) - -import qualified Reporting.Annotation as A - - - --- PARSER - - -newtype Parser x a = - Parser ( - forall b. - State - -> (a -> State -> b) -- consumed ok - -> (a -> State -> b) -- empty ok - -> (Row -> Col -> (Row -> Col -> x) -> b) -- consumed err - -> (Row -> Col -> (Row -> Col -> x) -> b) -- empty err - -> b - ) - - -data State = -- PERF try taking some out to avoid allocation - State - { _src :: ForeignPtr Word8 - , _pos :: !(Ptr Word8) - , _end :: !(Ptr Word8) - , _indent :: !Word16 - , _row :: !Row - , _col :: !Col - } - - -type Row = Word16 -type Col = Word16 - - - --- FUNCTOR - - -instance Functor (Parser x) where - {-# INLINE fmap #-} - fmap f (Parser parser) = - Parser $ \state cok eok cerr eerr -> - let - cok' a s = cok (f a) s - eok' a s = eok (f a) s - in - parser state cok' eok' cerr eerr - - - --- APPLICATIVE - - -instance Applicative.Applicative (Parser x) where - {-# INLINE pure #-} - pure = return - - {-# INLINE (<*>) #-} - (<*>) (Parser parserFunc) (Parser parserArg) = - Parser $ \state cok eok cerr eerr -> - let - cokF func s1 = - let - cokA arg s2 = cok (func arg) s2 - in - parserArg s1 cokA cokA cerr cerr - - eokF func s1 = - let - cokA arg s2 = cok (func arg) s2 - eokA arg s2 = eok (func arg) s2 - in - parserArg s1 cokA eokA cerr eerr - in - parserFunc state cokF eokF cerr eerr - - - --- ONE OF - - -{-# INLINE oneOf #-} -oneOf :: (Row -> Col -> x) -> [Parser x a] -> Parser x a -oneOf toError parsers = - Parser $ \state cok eok cerr eerr -> - oneOfHelp state cok eok cerr eerr toError parsers - - -oneOfHelp - :: State - -> (a -> State -> b) - -> (a -> State -> b) - -> (Row -> Col -> (Row -> Col -> x) -> b) - -> (Row -> Col -> (Row -> Col -> x) -> b) - -> (Row -> Col -> x) - -> [Parser x a] - -> b -oneOfHelp state cok eok cerr eerr toError parsers = - case parsers of - Parser parser : parsers -> - let - eerr' _ _ _ = - oneOfHelp state cok eok cerr eerr toError parsers - in - parser state cok eok cerr eerr' - - [] -> - let - (State _ _ _ _ row col) = state - in - eerr row col toError - - - --- ONE OF WITH FALLBACK - - -{-# INLINE oneOfWithFallback #-} -oneOfWithFallback :: [Parser x a] -> a -> Parser x a -- PERF is this function okay? Worried about allocation/laziness with fallback values. -oneOfWithFallback parsers fallback = - Parser $ \state cok eok cerr _ -> - oowfHelp state cok eok cerr parsers fallback - - -oowfHelp - :: State - -> (a -> State -> b) - -> (a -> State -> b) - -> (Row -> Col -> (Row -> Col -> x) -> b) - -> [Parser x a] - -> a - -> b -oowfHelp state cok eok cerr parsers fallback = - case parsers of - [] -> - eok fallback state - - Parser parser : parsers -> - let - eerr' _ _ _ = - oowfHelp state cok eok cerr parsers fallback - in - parser state cok eok cerr eerr' - - - --- MONAD - - -instance Monad (Parser x) where - {-# INLINE return #-} - return value = - Parser $ \state _ eok _ _ -> - eok value state - - {-# INLINE (>>=) #-} - (Parser parserA) >>= callback = - Parser $ \state cok eok cerr eerr -> - let - cok' a s = - case callback a of - Parser parserB -> parserB s cok cok cerr cerr - - eok' a s = - case callback a of - Parser parserB -> parserB s cok eok cerr eerr - in - parserA state cok' eok' cerr eerr - - - --- FROM BYTESTRING - - -fromByteString :: Parser x a -> (Row -> Col -> x) -> B.ByteString -> Either x a -fromByteString (Parser parser) toBadEnd (B.PS fptr offset length) = - B.accursedUnutterablePerformIO $ - let - toOk' = toOk toBadEnd - !pos = plusPtr (unsafeForeignPtrToPtr fptr) offset - !end = plusPtr pos length - !result = parser (State fptr pos end 0 1 1) toOk' toOk' toErr toErr - in - do touchForeignPtr fptr - return result - - -toOk :: (Row -> Col -> x) -> a -> State -> Either x a -toOk toBadEnd !a (State _ pos end _ row col) = - if pos == end - then Right a - else Left (toBadEnd row col) - - -toErr :: Row -> Col -> (Row -> Col -> x) -> Either x a -toErr row col toError = - Left (toError row col) - - - --- FROM SNIPPET - - -data Snippet = - Snippet - { _fptr :: ForeignPtr Word8 - , _offset :: Int - , _length :: Int - , _offRow :: Row - , _offCol :: Col - } - - -fromSnippet :: Parser x a -> (Row -> Col -> x) -> Snippet -> Either x a -fromSnippet (Parser parser) toBadEnd (Snippet fptr offset length row col) = - B.accursedUnutterablePerformIO $ - let - toOk' = toOk toBadEnd - !pos = plusPtr (unsafeForeignPtrToPtr fptr) offset - !end = plusPtr pos length - !result = parser (State fptr pos end 0 row col) toOk' toOk' toErr toErr - in - do touchForeignPtr fptr - return result - - - --- POSITION - - -getCol :: Parser x Word16 -getCol = - Parser $ \state@(State _ _ _ _ _ col) _ eok _ _ -> - eok col state - - -{-# INLINE getPosition #-} -getPosition :: Parser x A.Position -getPosition = - Parser $ \state@(State _ _ _ _ row col) _ eok _ _ -> - eok (A.Position row col) state - - -addLocation :: Parser x a -> Parser x (A.Located a) -addLocation (Parser parser) = - Parser $ \state@(State _ _ _ _ sr sc) cok eok cerr eerr -> - let - cok' a s@(State _ _ _ _ er ec) = cok (A.At (A.Region (A.Position sr sc) (A.Position er ec)) a) s - eok' a s@(State _ _ _ _ er ec) = eok (A.At (A.Region (A.Position sr sc) (A.Position er ec)) a) s - in - parser state cok' eok' cerr eerr - - -addEnd :: A.Position -> a -> Parser x (A.Located a) -addEnd start value = - Parser $ \state@(State _ _ _ _ row col) _ eok _ _ -> - eok (A.at start (A.Position row col) value) state - - - --- INDENT - - -getIndent :: Parser x Word16 -getIndent = - Parser $ \state@(State _ _ _ indent _ _) _ eok _ _ -> - eok indent state - - -setIndent :: Word16 -> Parser x () -setIndent indent = - Parser $ \(State src pos end _ row col) _ eok _ _ -> - let - !newState = State src pos end indent row col - in - eok () newState - - -withIndent :: Parser x a -> Parser x a -withIndent (Parser parser) = - Parser $ \(State src pos end oldIndent row col) cok eok cerr eerr -> - let - cok' a (State s p e _ r c) = cok a (State s p e oldIndent r c) - eok' a (State s p e _ r c) = eok a (State s p e oldIndent r c) - in - parser (State src pos end col row col) cok' eok' cerr eerr - - -withBacksetIndent :: Word16 -> Parser x a -> Parser x a -withBacksetIndent backset (Parser parser) = - Parser $ \(State src pos end oldIndent row col) cok eok cerr eerr -> - let - cok' a (State s p e _ r c) = cok a (State s p e oldIndent r c) - eok' a (State s p e _ r c) = eok a (State s p e oldIndent r c) - in - parser (State src pos end (col - backset) row col) cok' eok' cerr eerr - - - --- CONTEXT - - -inContext :: (x -> Row -> Col -> y) -> Parser y start -> Parser x a -> Parser y a -inContext addContext (Parser parserStart) (Parser parserA) = - Parser $ \state@(State _ _ _ _ row col) cok eok cerr eerr -> - let - cerrA r c tx = cerr row col (addContext (tx r c)) - eerrA r c tx = eerr row col (addContext (tx r c)) - - cokS _ s = parserA s cok cok cerrA cerrA - eokS _ s = parserA s cok eok cerrA eerrA - in - parserStart state cokS eokS cerr eerr - - -specialize :: (x -> Row -> Col -> y) -> Parser x a -> Parser y a -specialize addContext (Parser parser) = - Parser $ \state@(State _ _ _ _ row col) cok eok cerr eerr -> - let - cerr' r c tx = cerr row col (addContext (tx r c)) - eerr' r c tx = eerr row col (addContext (tx r c)) - in - parser state cok eok cerr' eerr' - - - --- SYMBOLS - - -word1 :: Word8 -> (Row -> Col -> x) -> Parser x () -word1 word toError = - Parser $ \(State src pos end indent row col) cok _ _ eerr -> - if pos < end && unsafeIndex pos == word then - let !newState = State src (plusPtr pos 1) end indent row (col + 1) in - cok () newState - else - eerr row col toError - - -word2 :: Word8 -> Word8 -> (Row -> Col -> x) -> Parser x () -word2 w1 w2 toError = - Parser $ \(State src pos end indent row col) cok _ _ eerr -> - let - !pos1 = plusPtr pos 1 - in - if pos1 < end && unsafeIndex pos == w1 && unsafeIndex pos1 == w2 then - let !newState = State src (plusPtr pos 2) end indent row (col + 2) in - cok () newState - else - eerr row col toError - - - --- LOW-LEVEL CHECKS - - -unsafeIndex :: Ptr Word8 -> Word8 -unsafeIndex ptr = - B.accursedUnutterablePerformIO (peek ptr) - - -{-# INLINE isWord #-} -isWord :: Ptr Word8 -> Ptr Word8 -> Word8 -> Bool -isWord pos end word = - pos < end && unsafeIndex pos == word - - -getCharWidth :: Word8 -> Int -getCharWidth word - | word < 0x80 = 1 - | word < 0xc0 = error "Need UTF-8 encoded input. Ran into unrecognized bits." - | word < 0xe0 = 2 - | word < 0xf0 = 3 - | word < 0xf8 = 4 - | True = error "Need UTF-8 encoded input. Ran into unrecognized bits." diff --git a/compiler/src/Parse/Shader.hs b/compiler/src/Parse/Shader.hs deleted file mode 100644 index 0311a721dc..0000000000 --- a/compiler/src/Parse/Shader.hs +++ /dev/null @@ -1,181 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE BangPatterns, UnboxedTuples #-} -module Parse.Shader - ( shader - ) - where - - -import qualified Data.ByteString.Internal as B -import qualified Data.ByteString.UTF8 as BS_UTF8 -import qualified Data.Map as Map -import qualified Data.Name as Name -import Data.Word (Word8) -import Foreign.Ptr (Ptr, plusPtr, minusPtr) -import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr) -import qualified Language.GLSL.Parser as GLP -import qualified Language.GLSL.Syntax as GLS -import qualified Text.Parsec as Parsec -import qualified Text.Parsec.Error as Parsec - -import qualified AST.Source as Src -import qualified AST.Utils.Shader as Shader -import Parse.Primitives (Parser, Row, Col) -import qualified Parse.Primitives as P -import qualified Reporting.Annotation as A -import qualified Reporting.Error.Syntax as E - - - --- SHADER - - -shader :: A.Position -> Parser E.Expr Src.Expr -shader start@(A.Position row col) = - do block <- parseBlock - shdr <- parseGlsl row col block - end <- P.getPosition - return (A.at start end (Src.Shader (Shader.fromChars block) shdr)) - - - --- BLOCK - - -parseBlock :: Parser E.Expr [Char] -parseBlock = - P.Parser $ \(P.State src pos end indent row col) cok _ cerr eerr -> - let - !pos6 = plusPtr pos 6 - in - if pos6 <= end - && P.unsafeIndex ( pos ) == 0x5B {- [ -} - && P.unsafeIndex (plusPtr pos 1) == 0x67 {- g -} - && P.unsafeIndex (plusPtr pos 2) == 0x6C {- l -} - && P.unsafeIndex (plusPtr pos 3) == 0x73 {- s -} - && P.unsafeIndex (plusPtr pos 4) == 0x6C {- l -} - && P.unsafeIndex (plusPtr pos 5) == 0x7C {- | -} - then - let - (# status, newPos, newRow, newCol #) = - eatShader pos6 end row (col + 6) - in - case status of - Good -> - let - !off = minusPtr pos6 (unsafeForeignPtrToPtr src) - !len = minusPtr newPos pos6 - !block = BS_UTF8.toString (B.PS src off len) - !newState = P.State src (plusPtr newPos 2) end indent newRow (newCol + 2) - in - cok block newState - - Unending -> - cerr row col E.EndlessShader - - else - eerr row col E.Start - - -data Status - = Good - | Unending - - -eatShader :: Ptr Word8 -> Ptr Word8 -> Row -> Col -> (# Status, Ptr Word8, Row, Col #) -eatShader pos end row col = - if pos >= end then - (# Unending, pos, row, col #) - - else - let !word = P.unsafeIndex pos in - if word == 0x007C {- | -} && P.isWord (plusPtr pos 1) end 0x5D {- ] -} then - (# Good, pos, row, col #) - - else if word == 0x0A {- \n -} then - eatShader (plusPtr pos 1) end (row + 1) 1 - - else - let !newPos = plusPtr pos (P.getCharWidth word) in - eatShader newPos end row (col + 1) - - - --- GLSL - - -parseGlsl :: Row -> Col -> [Char] -> Parser E.Expr Shader.Types -parseGlsl startRow startCol src = - case GLP.parse src of - Right (GLS.TranslationUnit decls) -> - return (foldr addInput emptyTypes (concatMap extractInputs decls)) - - Left err -> - let - pos = Parsec.errorPos err - row = fromIntegral (Parsec.sourceLine pos) - col = fromIntegral (Parsec.sourceColumn pos) - msg = - Parsec.showErrorMessages - "or" - "unknown parse error" - "expecting" - "unexpected" - "end of input" - (Parsec.errorMessages err) - in - if row == 1 - then failure startRow (startCol + 6 + col) msg - else failure (startRow + row - 1) col msg - - -failure :: Row -> Col -> [Char] -> Parser E.Expr a -failure row col msg = - P.Parser $ \(P.State _ _ _ _ _ _) _ _ cerr _ -> - cerr row col (E.ShaderProblem msg) - - - --- INPUTS - - -emptyTypes :: Shader.Types -emptyTypes = - Shader.Types Map.empty Map.empty Map.empty - - -addInput :: (GLS.StorageQualifier, Shader.Type, [Char]) -> Shader.Types -> Shader.Types -addInput (qual, tipe, name) glDecls = - case qual of - GLS.Attribute -> glDecls { Shader._attribute = Map.insert (Name.fromChars name) tipe (Shader._attribute glDecls) } - GLS.Uniform -> glDecls { Shader._uniform = Map.insert (Name.fromChars name) tipe (Shader._uniform glDecls) } - GLS.Varying -> glDecls { Shader._varying = Map.insert (Name.fromChars name) tipe (Shader._varying glDecls) } - _ -> error "Should never happen due to `extractInputs` function" - - -extractInputs :: GLS.ExternalDeclaration -> [(GLS.StorageQualifier, Shader.Type, [Char])] -extractInputs decl = - case decl of - GLS.Declaration - (GLS.InitDeclaration - (GLS.TypeDeclarator - (GLS.FullType - (Just (GLS.TypeQualSto qual)) - (GLS.TypeSpec _prec (GLS.TypeSpecNoPrecision tipe _mexpr1)))) - [GLS.InitDecl name _mexpr2 _mexpr3] - ) -> - case elem qual [GLS.Attribute, GLS.Varying, GLS.Uniform] of - False -> [] - True -> - case tipe of - GLS.Vec2 -> [(qual, Shader.V2, name)] - GLS.Vec3 -> [(qual, Shader.V3, name)] - GLS.Vec4 -> [(qual, Shader.V4, name)] - GLS.Mat4 -> [(qual, Shader.M4, name)] - GLS.Int -> [(qual, Shader.Int, name)] - GLS.Float -> [(qual, Shader.Float, name)] - GLS.Sampler2D -> [(qual, Shader.Texture, name)] - _ -> [] - _ -> [] - - diff --git a/compiler/src/Parse/Space.hs b/compiler/src/Parse/Space.hs deleted file mode 100644 index 897ef7bb27..0000000000 --- a/compiler/src/Parse/Space.hs +++ /dev/null @@ -1,273 +0,0 @@ -{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-} -{-# LANGUAGE BangPatterns, UnboxedTuples, OverloadedStrings #-} -module Parse.Space - ( Parser - -- - , chomp - , chompAndCheckIndent - -- - , checkIndent - , checkAligned - , checkFreshLine - -- - , docComment - ) - where - - -import Data.Word (Word8, Word16) -import Foreign.Ptr (Ptr, plusPtr, minusPtr) -import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr) - -import qualified AST.Source as Src -import Parse.Primitives (Row, Col) -import qualified Parse.Primitives as P -import qualified Reporting.Annotation as A -import qualified Reporting.Error.Syntax as E - - - --- SPACE PARSING - - -type Parser x a = - P.Parser x (a, A.Position) - - - --- CHOMP - - -chomp :: (E.Space -> Row -> Col -> x) -> P.Parser x () -chomp toError = - P.Parser $ \(P.State src pos end indent row col) cok _ cerr _ -> - let - (# status, newPos, newRow, newCol #) = eatSpaces pos end row col - in - case status of - Good -> - let - !newState = P.State src newPos end indent newRow newCol - in - cok () newState - - HasTab -> cerr newRow newCol (toError E.HasTab) - EndlessMultiComment -> cerr newRow newCol (toError E.EndlessMultiComment) - - - --- CHECKS -- to be called right after a `chomp` - - -checkIndent :: A.Position -> (Row -> Col -> x) -> P.Parser x () -checkIndent (A.Position endRow endCol) toError = - P.Parser $ \state@(P.State _ _ _ indent _ col) _ eok _ eerr -> - if col > indent && col > 1 - then eok () state - else eerr endRow endCol toError - - -checkAligned :: (Word16 -> Row -> Col -> x) -> P.Parser x () -checkAligned toError = - P.Parser $ \state@(P.State _ _ _ indent row col) _ eok _ eerr -> - if col == indent - then eok () state - else eerr row col (toError indent) - - -checkFreshLine :: (Row -> Col -> x) -> P.Parser x () -checkFreshLine toError = - P.Parser $ \state@(P.State _ _ _ _ row col) _ eok _ eerr -> - if col == 1 - then eok () state - else eerr row col toError - - - --- CHOMP AND CHECK - - -chompAndCheckIndent :: (E.Space -> Row -> Col -> x) -> (Row -> Col -> x) -> P.Parser x () -chompAndCheckIndent toSpaceError toIndentError = - P.Parser $ \(P.State src pos end indent row col) cok _ cerr _ -> - let - (# status, newPos, newRow, newCol #) = eatSpaces pos end row col - in - case status of - Good -> - if newCol > indent && newCol > 1 - then - - let - !newState = P.State src newPos end indent newRow newCol - in - cok () newState - - else - cerr row col toIndentError - - HasTab -> cerr newRow newCol (toSpaceError E.HasTab) - EndlessMultiComment -> cerr newRow newCol (toSpaceError E.EndlessMultiComment) - - - --- EAT SPACES - - -data Status - = Good - | HasTab - | EndlessMultiComment - - -eatSpaces :: Ptr Word8 -> Ptr Word8 -> Row -> Col -> (# Status, Ptr Word8, Row, Col #) -eatSpaces pos end row col = - if pos >= end then - (# Good, pos, row, col #) - - else - case P.unsafeIndex pos of - 0x20 {- -} -> - eatSpaces (plusPtr pos 1) end row (col + 1) - - 0x0A {- \n -} -> - eatSpaces (plusPtr pos 1) end (row + 1) 1 - - 0x7B {- { -} -> - eatMultiComment pos end row col - - 0x2D {- - -} -> - let !pos1 = plusPtr pos 1 in - if pos1 < end && P.unsafeIndex pos1 == 0x2D {- - -} then - eatLineComment (plusPtr pos 2) end row (col + 2) - else - (# Good, pos, row, col #) - - 0x0D {- \r -} -> - eatSpaces (plusPtr pos 1) end row col - - 0x09 {- \t -} -> - (# HasTab, pos, row, col #) - - _ -> - (# Good, pos, row, col #) - - - --- LINE COMMENTS - - -eatLineComment :: Ptr Word8 -> Ptr Word8 -> Row -> Col -> (# Status, Ptr Word8, Row, Col #) -eatLineComment pos end row col = - if pos >= end then - (# Good, pos, row, col #) - - else - let !word = P.unsafeIndex pos in - if word == 0x0A {- \n -} then - eatSpaces (plusPtr pos 1) end (row + 1) 1 - else - let !newPos = plusPtr pos (P.getCharWidth word) in - eatLineComment newPos end row (col + 1) - - - --- MULTI COMMENTS - - -eatMultiComment :: Ptr Word8 -> Ptr Word8 -> Row -> Col -> (# Status, Ptr Word8, Row, Col #) -eatMultiComment pos end row col = - let - !pos1 = plusPtr pos 1 - !pos2 = plusPtr pos 2 - in - if pos2 >= end then - (# Good, pos, row, col #) - - else if P.unsafeIndex pos1 == 0x2D {- - -} then - - if P.unsafeIndex pos2 == 0x7C {- | -} then - (# Good, pos, row, col #) - else - let - (# status, newPos, newRow, newCol #) = - eatMultiCommentHelp pos2 end row (col + 2) 1 - in - case status of - MultiGood -> eatSpaces newPos end newRow newCol - MultiTab -> (# HasTab, newPos, newRow, newCol #) - MultiEndless -> (# EndlessMultiComment, pos, row, col #) - - else - (# Good, pos, row, col #) - - -data MultiStatus - = MultiGood - | MultiTab - | MultiEndless - - -eatMultiCommentHelp :: Ptr Word8 -> Ptr Word8 -> Row -> Col -> Word16 -> (# MultiStatus, Ptr Word8, Row, Col #) -eatMultiCommentHelp pos end row col openComments = - if pos >= end then - (# MultiEndless, pos, row, col #) - - else - let !word = P.unsafeIndex pos in - if word == 0x0A {- \n -} then - eatMultiCommentHelp (plusPtr pos 1) end (row + 1) 1 openComments - - else if word == 0x09 {- \t -} then - (# MultiTab, pos, row, col #) - - else if word == 0x2D {- - -} && P.isWord (plusPtr pos 1) end 0x7D {- } -} then - if openComments == 1 then - (# MultiGood, plusPtr pos 2, row, col + 2 #) - else - eatMultiCommentHelp (plusPtr pos 2) end row (col + 2) (openComments - 1) - - else if word == 0x7B {- { -} && P.isWord (plusPtr pos 1) end 0x2D {- - -} then - eatMultiCommentHelp (plusPtr pos 2) end row (col + 2) (openComments + 1) - - else - let !newPos = plusPtr pos (P.getCharWidth word) in - eatMultiCommentHelp newPos end row (col + 1) openComments - - - --- DOCUMENTATION COMMENT - - -docComment :: (Row -> Col -> x) -> (E.Space -> Row -> Col -> x) -> P.Parser x Src.Comment -docComment toExpectation toSpaceError = - P.Parser $ \(P.State src pos end indent row col) cok _ cerr eerr -> - let - !pos3 = plusPtr pos 3 - in - if pos3 <= end - && P.unsafeIndex ( pos ) == 0x7B {- { -} - && P.unsafeIndex (plusPtr pos 1) == 0x2D {- - -} - && P.unsafeIndex (plusPtr pos 2) == 0x7C {- | -} - then - let - !col3 = col + 3 - - (# status, newPos, newRow, newCol #) = - eatMultiCommentHelp pos3 end row col3 1 - in - case status of - MultiGood -> - let - !off = minusPtr pos3 (unsafeForeignPtrToPtr src) - !len = minusPtr newPos pos3 - 2 - !snippet = P.Snippet src off len row col3 - !comment = Src.Comment snippet - !newState = P.State src newPos end indent newRow newCol - in - cok comment newState - - MultiTab -> cerr newRow newCol (toSpaceError E.HasTab) - MultiEndless -> cerr row col (toSpaceError E.EndlessMultiComment) - else - eerr row col toExpectation diff --git a/compiler/src/Parse/String.hs b/compiler/src/Parse/String.hs deleted file mode 100644 index f23e411647..0000000000 --- a/compiler/src/Parse/String.hs +++ /dev/null @@ -1,343 +0,0 @@ -{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-} -{-# LANGUAGE BangPatterns, MagicHash, OverloadedStrings, UnboxedTuples #-} -module Parse.String - ( string - , character - ) - where - - -import qualified Data.Utf8 as Utf8 -import Data.Word (Word8, Word16) -import Foreign.Ptr (Ptr, plusPtr, minusPtr) - -import qualified Elm.String as ES -import Parse.Primitives (Parser, Row, Col) -import qualified Parse.Number as Number -import qualified Parse.Primitives as P -import qualified Reporting.Error.Syntax as E - - - --- CHARACTER - - -character :: (Row -> Col -> x) -> (E.Char -> Row -> Col -> x) -> Parser x ES.String -character toExpectation toError = - P.Parser $ \(P.State src pos end indent row col) cok _ cerr eerr -> - if pos >= end || P.unsafeIndex pos /= 0x27 {- ' -} then - eerr row col toExpectation - - else - case chompChar (plusPtr pos 1) end row (col + 1) 0 placeholder of - Good newPos newCol numChars mostRecent -> - if numChars /= 1 then - cerr row col (toError (E.CharNotString (fromIntegral (newCol - col)))) - else - let - !newState = P.State src newPos end indent row newCol - !char = ES.fromChunks [mostRecent] - in - cok char newState - - CharEndless newCol -> - cerr row newCol (toError E.CharEndless) - - CharEscape r c escape -> - cerr r c (toError (E.CharEscape escape)) - - -data CharResult - = Good (Ptr Word8) Col Word16 ES.Chunk - | CharEndless Col - | CharEscape Row Col E.Escape - - -chompChar :: Ptr Word8 -> Ptr Word8 -> Row -> Col -> Word16 -> ES.Chunk -> CharResult -chompChar pos end row col numChars mostRecent = - if pos >= end then - CharEndless col - - else - let - !word = P.unsafeIndex pos - in - if word == 0x27 {- ' -} then - Good (plusPtr pos 1) (col + 1) numChars mostRecent - - else if word == 0x0A {- \n -} then - CharEndless col - - else if word == 0x22 {- " -} then - chompChar (plusPtr pos 1) end row (col + 1) (numChars + 1) doubleQuote - - else if word == 0x5C {- \ -} then - case eatEscape (plusPtr pos 1) end row col of - EscapeNormal -> - chompChar (plusPtr pos 2) end row (col + 2) (numChars + 1) (ES.Slice pos 2) - - EscapeUnicode delta code -> - chompChar (plusPtr pos delta) end row (col + fromIntegral delta) (numChars + 1) (ES.CodePoint code) - - EscapeProblem r c badEscape -> - CharEscape r c badEscape - - EscapeEndOfFile -> - CharEndless col - - else - let - !width = P.getCharWidth word - !newPos = plusPtr pos width - in - chompChar newPos end row (col + 1) (numChars + 1) (ES.Slice pos width) - - - --- STRINGS - - -string :: (Row -> Col -> x) -> (E.String -> Row -> Col -> x) -> Parser x ES.String -string toExpectation toError = - P.Parser $ \(P.State src pos end indent row col) cok _ cerr eerr -> - if isDoubleQuote pos end then - - let - !pos1 = plusPtr pos 1 - in - case - if isDoubleQuote pos1 end then - let !pos2 = plusPtr pos 2 in - if isDoubleQuote pos2 end then - let - !pos3 = plusPtr pos 3 - !col3 = col + 3 - in - multiString pos3 end row col3 pos3 row col mempty - else - Ok pos2 row (col + 2) Utf8.empty - else - singleString pos1 end row (col + 1) pos1 mempty - of - Ok newPos newRow newCol utf8 -> - let - !newState = - P.State src newPos end indent newRow newCol - in - cok utf8 newState - - Err r c x -> - cerr r c (toError x) - - else - eerr row col toExpectation - - -{-# INLINE isDoubleQuote #-} -isDoubleQuote :: Ptr Word8 -> Ptr Word8 -> Bool -isDoubleQuote pos end = - pos < end && P.unsafeIndex pos == 0x22 {- " -} - - -data StringResult - = Ok (Ptr Word8) Row Col !ES.String - | Err Row Col E.String - - -finalize :: Ptr Word8 -> Ptr Word8 -> [ES.Chunk] -> ES.String -finalize start end revChunks = - ES.fromChunks $ reverse $ - if start == end then - revChunks - else - ES.Slice start (minusPtr end start) : revChunks - - -addEscape :: ES.Chunk -> Ptr Word8 -> Ptr Word8 -> [ES.Chunk] -> [ES.Chunk] -addEscape chunk start end revChunks = - if start == end then - chunk : revChunks - else - chunk : ES.Slice start (minusPtr end start) : revChunks - - - --- SINGLE STRINGS - - -singleString :: Ptr Word8 -> Ptr Word8 -> Row -> Col -> Ptr Word8 -> [ES.Chunk] -> StringResult -singleString pos end row col initialPos revChunks = - if pos >= end then - Err row col E.StringEndless_Single - - else - let - !word = P.unsafeIndex pos - in - if word == 0x22 {- " -} then - Ok (plusPtr pos 1) row (col + 1) $ - finalize initialPos pos revChunks - - else if word == 0x0A {- \n -} then - Err row col E.StringEndless_Single - - else if word == 0x27 {- ' -} then - let !newPos = plusPtr pos 1 in - singleString newPos end row (col + 1) newPos $ - addEscape singleQuote initialPos pos revChunks - - else if word == 0x5C {- \ -} then - case eatEscape (plusPtr pos 1) end row col of - EscapeNormal -> - singleString (plusPtr pos 2) end row (col + 2) initialPos revChunks - - EscapeUnicode delta code -> - let !newPos = plusPtr pos delta in - singleString newPos end row (col + fromIntegral delta) newPos $ - addEscape (ES.CodePoint code) initialPos pos revChunks - - EscapeProblem r c x -> - Err r c (E.StringEscape x) - - EscapeEndOfFile -> - Err row (col + 1) E.StringEndless_Single - - else - let !newPos = plusPtr pos (P.getCharWidth word) in - singleString newPos end row (col + 1) initialPos revChunks - - - --- MULTI STRINGS - - -multiString :: Ptr Word8 -> Ptr Word8 -> Row -> Col -> Ptr Word8 -> Row -> Col -> [ES.Chunk] -> StringResult -multiString pos end row col initialPos sr sc revChunks = - if pos >= end then - Err sr sc E.StringEndless_Multi - - else - let !word = P.unsafeIndex pos in - if word == 0x22 {- " -} && isDoubleQuote (plusPtr pos 1) end && isDoubleQuote (plusPtr pos 2) end then - Ok (plusPtr pos 3) row (col + 3) $ - finalize initialPos pos revChunks - - else if word == 0x27 {- ' -} then - let !pos1 = plusPtr pos 1 in - multiString pos1 end row (col + 1) pos1 sr sc $ - addEscape singleQuote initialPos pos revChunks - - else if word == 0x0A {- \n -} then - let !pos1 = plusPtr pos 1 in - multiString pos1 end (row + 1) 1 pos1 sr sc $ - addEscape newline initialPos pos revChunks - - else if word == 0x0D {- \r -} then - let !pos1 = plusPtr pos 1 in - multiString pos1 end row col pos1 sr sc $ - addEscape carriageReturn initialPos pos revChunks - - else if word == 0x5C {- \ -} then - case eatEscape (plusPtr pos 1) end row col of - EscapeNormal -> - multiString (plusPtr pos 2) end row (col + 2) initialPos sr sc revChunks - - EscapeUnicode delta code -> - let !newPos = plusPtr pos delta in - multiString newPos end row (col + fromIntegral delta) newPos sr sc $ - addEscape (ES.CodePoint code) initialPos pos revChunks - - EscapeProblem r c x -> - Err r c (E.StringEscape x) - - EscapeEndOfFile -> - Err sr sc E.StringEndless_Multi - - else - let !newPos = plusPtr pos (P.getCharWidth word) in - multiString newPos end row (col + 1) initialPos sr sc revChunks - - - --- ESCAPE CHARACTERS - - -data Escape - = EscapeNormal - | EscapeUnicode !Int !Int - | EscapeEndOfFile - | EscapeProblem Row Col E.Escape - - -eatEscape :: Ptr Word8 -> Ptr Word8 -> Row -> Col -> Escape -eatEscape pos end row col = - if pos >= end then - EscapeEndOfFile - - else - case P.unsafeIndex pos of - 0x6E {- n -} -> EscapeNormal - 0x72 {- r -} -> EscapeNormal - 0x74 {- t -} -> EscapeNormal - 0x22 {- " -} -> EscapeNormal - 0x27 {- ' -} -> EscapeNormal - 0x5C {- \ -} -> EscapeNormal - 0x75 {- u -} -> eatUnicode (plusPtr pos 1) end row col - _ -> EscapeProblem row col E.EscapeUnknown - - -eatUnicode :: Ptr Word8 -> Ptr Word8 -> Row -> Col -> Escape -eatUnicode pos end row col = - if pos >= end || P.unsafeIndex pos /= 0x7B {- { -} then - EscapeProblem row col (E.BadUnicodeFormat 2) - else - let - !digitPos = plusPtr pos 1 - (# newPos, code #) = Number.chompHex digitPos end - !numDigits = minusPtr newPos digitPos - in - if newPos >= end || P.unsafeIndex newPos /= 0x7D {- } -} then - EscapeProblem row col $ E.BadUnicodeFormat (2 + fromIntegral (minusPtr newPos pos)) - - else if code < 0 || 0x10FFFF < code then - EscapeProblem row col $ E.BadUnicodeCode (3 + fromIntegral (minusPtr newPos pos)) - - else if numDigits < 4 || 6 < numDigits then - EscapeProblem row col $ - E.BadUnicodeLength - (3 + fromIntegral (minusPtr newPos pos)) - numDigits - code - - else - EscapeUnicode (numDigits + 4) code - - -{-# NOINLINE singleQuote #-} -singleQuote :: ES.Chunk -singleQuote = - ES.Escape 0x27 {-'-} - - -{-# NOINLINE doubleQuote #-} -doubleQuote :: ES.Chunk -doubleQuote = - ES.Escape 0x22 {-"-} - - -{-# NOINLINE newline #-} -newline :: ES.Chunk -newline = - ES.Escape 0x6E {-n-} - - -{-# NOINLINE carriageReturn #-} -carriageReturn :: ES.Chunk -carriageReturn = - ES.Escape 0x72 {-r-} - - -{-# NOINLINE placeholder #-} -placeholder :: ES.Chunk -placeholder = - ES.CodePoint 0xFFFD {-replacement character-} diff --git a/compiler/src/Parse/Symbol.hs b/compiler/src/Parse/Symbol.hs deleted file mode 100644 index 3d7bc81f56..0000000000 --- a/compiler/src/Parse/Symbol.hs +++ /dev/null @@ -1,79 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE BangPatterns, OverloadedStrings #-} -module Parse.Symbol - ( operator - , BadOperator(..) - , binopCharSet - ) - where - - -import qualified Data.Char as Char -import qualified Data.IntSet as IntSet -import qualified Data.Name as Name -import qualified Data.Vector as Vector -import Foreign.Ptr (Ptr, plusPtr, minusPtr) -import GHC.Word (Word8) - -import Parse.Primitives (Parser, Row, Col) -import qualified Parse.Primitives as P - - - --- OPERATOR - - -data BadOperator - = BadDot - | BadPipe - | BadArrow - | BadEquals - | BadHasType - - -operator :: (Row -> Col -> x) -> (BadOperator -> Row -> Col -> x) -> Parser x Name.Name -operator toExpectation toError = - P.Parser $ \(P.State src pos end indent row col) cok _ cerr eerr -> - let !newPos = chompOps pos end in - if pos == newPos then - eerr row col toExpectation - - else - case Name.fromPtr pos newPos of - "." -> eerr row col (toError BadDot) - "|" -> cerr row col (toError BadPipe) - "->" -> cerr row col (toError BadArrow) - "=" -> cerr row col (toError BadEquals) - ":" -> cerr row col (toError BadHasType) - op -> - let - !newCol = col + fromIntegral (minusPtr newPos pos) - !newState = P.State src newPos end indent row newCol - in - cok op newState - - -chompOps :: Ptr Word8 -> Ptr Word8 -> Ptr Word8 -chompOps pos end = - if pos < end && isBinopCharHelp (P.unsafeIndex pos) then - chompOps (plusPtr pos 1) end - else - pos - - -{-# INLINE isBinopCharHelp #-} -isBinopCharHelp :: Word8 -> Bool -isBinopCharHelp word = - word < 128 && Vector.unsafeIndex binopCharVector (fromIntegral word) - - -{-# NOINLINE binopCharVector #-} -binopCharVector :: Vector.Vector Bool -binopCharVector = - Vector.generate 128 (\i -> IntSet.member i binopCharSet) - - -{-# NOINLINE binopCharSet #-} -binopCharSet :: IntSet.IntSet -binopCharSet = - IntSet.fromList (map Char.ord "+-/*=.<>:&|^?%!") diff --git a/compiler/src/Parse/Type.hs b/compiler/src/Parse/Type.hs deleted file mode 100644 index ff18dc78b6..0000000000 --- a/compiler/src/Parse/Type.hs +++ /dev/null @@ -1,203 +0,0 @@ -{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-} -{-# LANGUAGE OverloadedStrings #-} -module Parse.Type - ( expression - , variant - ) - where - - -import qualified Data.Name as Name - -import qualified AST.Source as Src -import Parse.Primitives (Parser, addLocation, addEnd, getPosition, inContext, specialize, oneOf, oneOfWithFallback, word1, word2) -import qualified Parse.Space as Space -import qualified Parse.Variable as Var -import qualified Reporting.Annotation as A -import qualified Reporting.Error.Syntax as E - - - --- TYPE TERMS - - -term :: Parser E.Type Src.Type -term = - do start <- getPosition - oneOf E.TStart - [ - -- types with no arguments (Int, Float, etc.) - do upper <- Var.foreignUpper E.TStart - end <- getPosition - let region = A.Region start end - return $ A.At region $ - case upper of - Var.Unqualified name -> - Src.TType region name [] - - Var.Qualified home name -> - Src.TTypeQual region home name [] - , - -- type variables - do var <- Var.lower E.TStart - addEnd start (Src.TVar var) - , - -- tuples - inContext E.TTuple (word1 0x28 {-(-} E.TStart) $ - oneOf E.TTupleOpen - [ do word1 0x29 {-)-} E.TTupleOpen - addEnd start Src.TUnit - , do Space.chompAndCheckIndent E.TTupleSpace E.TTupleIndentType1 - (tipe, end) <- specialize E.TTupleType expression - Space.checkIndent end E.TTupleIndentEnd - chompTupleEnd start tipe [] - ] - , - -- records - inContext E.TRecord (word1 0x7B {- { -} E.TStart) $ - do Space.chompAndCheckIndent E.TRecordSpace E.TRecordIndentOpen - oneOf E.TRecordOpen - [ do word1 0x7D {-}-} E.TRecordEnd - addEnd start (Src.TRecord [] Nothing) - , do name <- addLocation (Var.lower E.TRecordField) - Space.chompAndCheckIndent E.TRecordSpace E.TRecordIndentColon - oneOf E.TRecordColon - [ do word1 0x7C {-|-} E.TRecordColon - Space.chompAndCheckIndent E.TRecordSpace E.TRecordIndentField - field <- chompField - fields <- chompRecordEnd [field] - addEnd start (Src.TRecord fields (Just name)) - , do word1 0x3A {-:-} E.TRecordColon - Space.chompAndCheckIndent E.TRecordSpace E.TRecordIndentType - (tipe, end) <- specialize E.TRecordType expression - Space.checkIndent end E.TRecordIndentEnd - fields <- chompRecordEnd [(name, tipe)] - addEnd start (Src.TRecord fields Nothing) - ] - ] - ] - - - --- TYPE EXPRESSIONS - - -expression :: Space.Parser E.Type Src.Type -expression = - do start <- getPosition - term1@(tipe1, end1) <- - oneOf E.TStart - [ app start - , do eterm <- term - end <- getPosition - Space.chomp E.TSpace - return (eterm, end) - ] - oneOfWithFallback - [ do Space.checkIndent end1 E.TIndentStart -- should never trigger - word2 0x2D 0x3E {-->-} E.TStart -- could just be another type instead - Space.chompAndCheckIndent E.TSpace E.TIndentStart - (tipe2, end2) <- expression - let tipe = A.at start end2 (Src.TLambda tipe1 tipe2) - return ( tipe, end2 ) - ] - term1 - - - --- TYPE CONSTRUCTORS - - -app :: A.Position -> Space.Parser E.Type Src.Type -app start = - do upper <- Var.foreignUpper E.TStart - upperEnd <- getPosition - Space.chomp E.TSpace - (args, end) <- chompArgs [] upperEnd - - let region = A.Region start upperEnd - let tipe = - case upper of - Var.Unqualified name -> - Src.TType region name args - - Var.Qualified home name -> - Src.TTypeQual region home name args - - return ( A.at start end tipe, end ) - - -chompArgs :: [Src.Type] -> A.Position -> Space.Parser E.Type [Src.Type] -chompArgs args end = - oneOfWithFallback - [ do Space.checkIndent end E.TIndentStart - arg <- term - newEnd <- getPosition - Space.chomp E.TSpace - chompArgs (arg:args) newEnd - ] - (reverse args, end) - - - --- TUPLES - - -chompTupleEnd :: A.Position -> Src.Type -> [Src.Type] -> Parser E.TTuple Src.Type -chompTupleEnd start firstType revTypes = - oneOf E.TTupleEnd - [ do word1 0x2C {-,-} E.TTupleEnd - Space.chompAndCheckIndent E.TTupleSpace E.TTupleIndentTypeN - (tipe, end) <- specialize E.TTupleType expression - Space.checkIndent end E.TTupleIndentEnd - chompTupleEnd start firstType (tipe : revTypes) - , do word1 0x29 {-)-} E.TTupleEnd - case reverse revTypes of - [] -> - return firstType - - secondType : otherTypes -> - addEnd start (Src.TTuple firstType secondType otherTypes) - ] - - - --- RECORD - - -type Field = ( A.Located Name.Name, Src.Type ) - - -chompRecordEnd :: [Field] -> Parser E.TRecord [Field] -chompRecordEnd fields = - oneOf E.TRecordEnd - [ do word1 0x2C {-,-} E.TRecordEnd - Space.chompAndCheckIndent E.TRecordSpace E.TRecordIndentField - field <- chompField - chompRecordEnd (field : fields) - , do word1 0x7D {-}-} E.TRecordEnd - return (reverse fields) - ] - - -chompField :: Parser E.TRecord Field -chompField = - do name <- addLocation (Var.lower E.TRecordField) - Space.chompAndCheckIndent E.TRecordSpace E.TRecordIndentColon - word1 0x3A {-:-} E.TRecordColon - Space.chompAndCheckIndent E.TRecordSpace E.TRecordIndentType - (tipe, end) <- specialize E.TRecordType expression - Space.checkIndent end E.TRecordIndentEnd - return (name, tipe) - - - --- VARIANT - - -variant :: Space.Parser E.CustomType (A.Located Name.Name, [Src.Type]) -variant = - do name@(A.At (A.Region _ nameEnd) _) <- addLocation (Var.upper E.CT_Variant) - Space.chomp E.CT_Space - (args, end) <- specialize E.CT_VariantArg (chompArgs [] nameEnd) - return ( (name, args), end ) diff --git a/compiler/src/Parse/Variable.hs b/compiler/src/Parse/Variable.hs deleted file mode 100644 index f3d86145fc..0000000000 --- a/compiler/src/Parse/Variable.hs +++ /dev/null @@ -1,387 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE BangPatterns, MagicHash, OverloadedStrings, UnboxedTuples #-} -module Parse.Variable - ( lower - , upper - , moduleName - , Upper(..) - , foreignUpper - , foreignAlpha - , chompInnerChars - , getUpperWidth - , getInnerWidth - , getInnerWidthHelp - , reservedWords - ) - where - - -import qualified Data.Char as Char -import qualified Data.Name as Name -import qualified Data.Set as Set -import Data.Word (Word8) -import Foreign.Ptr (Ptr, plusPtr) -import GHC.Exts (Char(C#), Int#, (+#), (-#), chr#, uncheckedIShiftL#, word2Int#) -import GHC.Word (Word8(W8#)) - -import qualified AST.Source as Src -import Parse.Primitives (Parser, Row, Col, unsafeIndex) -import qualified Parse.Primitives as P - - - --- LOCAL UPPER - - -upper :: (Row -> Col -> x) -> Parser x Name.Name -upper toError = - P.Parser $ \(P.State src pos end indent row col) cok _ _ eerr -> - let (# newPos, newCol #) = chompUpper pos end col in - if pos == newPos then - eerr row col toError - else - let !name = Name.fromPtr pos newPos in - cok name (P.State src newPos end indent row newCol) - - - --- LOCAL LOWER - - -lower :: (Row -> Col -> x) -> Parser x Name.Name -lower toError = - P.Parser $ \(P.State src pos end indent row col) cok _ _ eerr -> - let (# newPos, newCol #) = chompLower pos end col in - if pos == newPos then - eerr row col toError - else - let !name = Name.fromPtr pos newPos in - if Set.member name reservedWords then - eerr row col toError - else - let - !newState = - P.State src newPos end indent row newCol - in - cok name newState - - -{-# NOINLINE reservedWords #-} -reservedWords :: Set.Set Name.Name -- PERF try using a trie instead -reservedWords = - Set.fromList - [ "if", "then", "else" - , "case", "of" - , "let", "in" - , "type" - , "module", "where" - , "import", "exposing" - , "as" - , "port" - ] - - - --- MODULE NAME - - -moduleName :: (Row -> Col -> x) -> Parser x Name.Name -moduleName toError = - P.Parser $ \(P.State src pos end indent row col) cok _ cerr eerr -> - let - (# pos1, col1 #) = chompUpper pos end col - in - if pos == pos1 then - eerr row col toError - else - let - (# status, newPos, newCol #) = moduleNameHelp pos1 end col1 - in - case status of - Good -> - let - !name = Name.fromPtr pos newPos - !newState = P.State src newPos end indent row newCol - in - cok name newState - - Bad -> - cerr row newCol toError - - -data ModuleNameStatus - = Good - | Bad - - -moduleNameHelp :: Ptr Word8 -> Ptr Word8 -> Col -> (# ModuleNameStatus, Ptr Word8, Col #) -moduleNameHelp pos end col = - if isDot pos end then - let - !pos1 = plusPtr pos 1 - (# newPos, newCol #) = chompUpper pos1 end (col + 1) - in - if pos1 == newPos then - (# Bad, newPos, newCol #) - else - moduleNameHelp newPos end newCol - - else - (# Good, pos, col #) - - - --- FOREIGN UPPER - - -data Upper - = Unqualified Name.Name - | Qualified Name.Name Name.Name - - -foreignUpper :: (Row -> Col -> x) -> Parser x Upper -foreignUpper toError = - P.Parser $ \(P.State src pos end indent row col) cok _ _ eerr -> - let (# upperStart, upperEnd, newCol #) = foreignUpperHelp pos end col in - if upperStart == upperEnd then - eerr row newCol toError - else - let - !newState = P.State src upperEnd end indent row newCol - !name = Name.fromPtr upperStart upperEnd - !upperName = - if upperStart == pos then - Unqualified name - else - let !home = Name.fromPtr pos (plusPtr upperStart (-1)) in - Qualified home name - in - cok upperName newState - - -foreignUpperHelp :: Ptr Word8 -> Ptr Word8 -> Col -> (# Ptr Word8, Ptr Word8, Col #) -foreignUpperHelp pos end col = - let - (# newPos, newCol #) = chompUpper pos end col - in - if pos == newPos then - (# pos, pos, col #) - - else if isDot newPos end then - foreignUpperHelp (plusPtr newPos 1) end (newCol + 1) - - else - (# pos, newPos, newCol #) - - - --- FOREIGN ALPHA - - -foreignAlpha :: (Row -> Col -> x) -> Parser x Src.Expr_ -foreignAlpha toError = - P.Parser $ \(P.State src pos end indent row col) cok _ _ eerr -> - let (# alphaStart, alphaEnd, newCol, varType #) = foreignAlphaHelp pos end col in - if alphaStart == alphaEnd then - eerr row newCol toError - else - let - !newState = P.State src alphaEnd end indent row newCol - !name = Name.fromPtr alphaStart alphaEnd - in - if alphaStart == pos then - if Set.member name reservedWords then - eerr row col toError - else - cok (Src.Var varType name) newState - else - let !home = Name.fromPtr pos (plusPtr alphaStart (-1)) in - cok (Src.VarQual varType home name) newState - - -foreignAlphaHelp :: Ptr Word8 -> Ptr Word8 -> Col -> (# Ptr Word8, Ptr Word8, Col, Src.VarType #) -foreignAlphaHelp pos end col = - let - (# lowerPos, lowerCol #) = chompLower pos end col - in - if pos < lowerPos then - (# pos, lowerPos, lowerCol, Src.LowVar #) - - else - let - (# upperPos, upperCol #) = chompUpper pos end col - in - if pos == upperPos then - (# pos, pos, col, Src.CapVar #) - - else if isDot upperPos end then - foreignAlphaHelp (plusPtr upperPos 1) end (upperCol + 1) - - else - (# pos, upperPos, upperCol, Src.CapVar #) - - - ----- CHAR CHOMPERS ---- - - - --- DOTS - - -{-# INLINE isDot #-} -isDot :: Ptr Word8 -> Ptr Word8 -> Bool -isDot pos end = - pos < end && unsafeIndex pos == 0x2e {- . -} - - - --- UPPER CHARS - - -chompUpper :: Ptr Word8 -> Ptr Word8 -> Col -> (# Ptr Word8, Col #) -chompUpper pos end col = - let !width = getUpperWidth pos end in - if width == 0 then - (# pos, col #) - else - chompInnerChars (plusPtr pos width) end (col + 1) - - -{-# INLINE getUpperWidth #-} -getUpperWidth :: Ptr Word8 -> Ptr Word8 -> Int -getUpperWidth pos end = - if pos < end then - getUpperWidthHelp pos end (unsafeIndex pos) - else - 0 - - -{-# INLINE getUpperWidthHelp #-} -getUpperWidthHelp :: Ptr Word8 -> Ptr Word8 -> Word8 -> Int -getUpperWidthHelp pos _ word - | 0x41 {- A -} <= word && word <= 0x5A {- Z -} = 1 - | word < 0xc0 = 0 - | word < 0xe0 = if Char.isUpper (chr2 pos word) then 2 else 0 - | word < 0xf0 = if Char.isUpper (chr3 pos word) then 3 else 0 - | word < 0xf8 = if Char.isUpper (chr4 pos word) then 4 else 0 - | True = 0 - - - --- LOWER CHARS - - -chompLower :: Ptr Word8 -> Ptr Word8 -> Col -> (# Ptr Word8, Col #) -chompLower pos end col = - let !width = getLowerWidth pos end in - if width == 0 then - (# pos, col #) - else - chompInnerChars (plusPtr pos width) end (col + 1) - - -{-# INLINE getLowerWidth #-} -getLowerWidth :: Ptr Word8 -> Ptr Word8 -> Int -getLowerWidth pos end = - if pos < end then - getLowerWidthHelp pos end (unsafeIndex pos) - else - 0 - - -{-# INLINE getLowerWidthHelp #-} -getLowerWidthHelp :: Ptr Word8 -> Ptr Word8 -> Word8 -> Int -getLowerWidthHelp pos _ word - | 0x61 {- a -} <= word && word <= 0x7A {- z -} = 1 - | word < 0xc0 = 0 - | word < 0xe0 = if Char.isLower (chr2 pos word) then 2 else 0 - | word < 0xf0 = if Char.isLower (chr3 pos word) then 3 else 0 - | word < 0xf8 = if Char.isLower (chr4 pos word) then 4 else 0 - | True = 0 - - - --- INNER CHARS - - -chompInnerChars :: Ptr Word8 -> Ptr Word8 -> Col -> (# Ptr Word8, Col #) -chompInnerChars !pos end !col = - let !width = getInnerWidth pos end in - if width == 0 then - (# pos, col #) - else - chompInnerChars (plusPtr pos width) end (col + 1) - - -getInnerWidth :: Ptr Word8 -> Ptr Word8 -> Int -getInnerWidth pos end = - if pos < end then - getInnerWidthHelp pos end (unsafeIndex pos) - else - 0 - - -{-# INLINE getInnerWidthHelp #-} -getInnerWidthHelp :: Ptr Word8 -> Ptr Word8 -> Word8 -> Int -getInnerWidthHelp pos _ word - | 0x61 {- a -} <= word && word <= 0x7A {- z -} = 1 - | 0x41 {- A -} <= word && word <= 0x5A {- Z -} = 1 - | 0x30 {- 0 -} <= word && word <= 0x39 {- 9 -} = 1 - | word == 0x5F {- _ -} = 1 - | word < 0xc0 = 0 - | word < 0xe0 = if Char.isAlpha (chr2 pos word) then 2 else 0 - | word < 0xf0 = if Char.isAlpha (chr3 pos word) then 3 else 0 - | word < 0xf8 = if Char.isAlpha (chr4 pos word) then 4 else 0 - | True = 0 - - - --- EXTRACT CHARACTERS - - -{-# INLINE chr2 #-} -chr2 :: Ptr Word8 -> Word8 -> Char -chr2 pos firstWord = - let - !i1# = unpack firstWord - !i2# = unpack (unsafeIndex (plusPtr pos 1)) - !c1# = uncheckedIShiftL# (i1# -# 0xC0#) 6# - !c2# = i2# -# 0x80# - in - C# (chr# (c1# +# c2#)) - - -{-# INLINE chr3 #-} -chr3 :: Ptr Word8 -> Word8 -> Char -chr3 pos firstWord = - let - !i1# = unpack firstWord - !i2# = unpack (unsafeIndex (plusPtr pos 1)) - !i3# = unpack (unsafeIndex (plusPtr pos 2)) - !c1# = uncheckedIShiftL# (i1# -# 0xE0#) 12# - !c2# = uncheckedIShiftL# (i2# -# 0x80#) 6# - !c3# = i3# -# 0x80# - in - C# (chr# (c1# +# c2# +# c3#)) - - -{-# INLINE chr4 #-} -chr4 :: Ptr Word8 -> Word8 -> Char -chr4 pos firstWord = - let - !i1# = unpack firstWord - !i2# = unpack (unsafeIndex (plusPtr pos 1)) - !i3# = unpack (unsafeIndex (plusPtr pos 2)) - !i4# = unpack (unsafeIndex (plusPtr pos 3)) - !c1# = uncheckedIShiftL# (i1# -# 0xF0#) 18# - !c2# = uncheckedIShiftL# (i2# -# 0x80#) 12# - !c3# = uncheckedIShiftL# (i3# -# 0x80#) 6# - !c4# = i4# -# 0x80# - in - C# (chr# (c1# +# c2# +# c3# +# c4#)) - - -unpack :: Word8 -> Int# -unpack (W8# word#) = - word2Int# word# diff --git a/compiler/src/Reporting/Annotation.hs b/compiler/src/Reporting/Annotation.hs deleted file mode 100644 index 71dc021155..0000000000 --- a/compiler/src/Reporting/Annotation.hs +++ /dev/null @@ -1,103 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -module Reporting.Annotation - ( Located(..) - , Position(..) - , Region(..) - , traverse - , toValue - , merge - , at - , toRegion - , mergeRegions - , zero - , one - ) - where - - -import Prelude hiding (traverse) -import Control.Monad (liftM2) -import Data.Binary (Binary, get, put) -import Data.Word (Word16) - - - --- LOCATED - - -data Located a = - At Region a -- PERF see if unpacking region is helpful - - -instance Functor Located where - fmap f (At region a) = - At region (f a) - - -traverse :: (Functor f) => (a -> f b) -> Located a -> f (Located b) -traverse func (At region value) = - At region <$> func value - - -toValue :: Located a -> a -toValue (At _ value) = - value - - -merge :: Located a -> Located b -> value -> Located value -merge (At r1 _) (At r2 _) value = - At (mergeRegions r1 r2) value - - - --- POSITION - - -data Position = - Position - {-# UNPACK #-} !Word16 - {-# UNPACK #-} !Word16 - deriving (Eq) - - -at :: Position -> Position -> a -> Located a -at start end a = - At (Region start end) a - - - --- REGION - - -data Region = Region Position Position - deriving (Eq) - - -toRegion :: Located a -> Region -toRegion (At region _) = - region - - -mergeRegions :: Region -> Region -> Region -mergeRegions (Region start _) (Region _ end) = - Region start end - - -zero :: Region -zero = - Region (Position 0 0) (Position 0 0) - - -one :: Region -one = - Region (Position 1 1) (Position 1 1) - - -instance Binary Region where - put (Region a b) = put a >> put b - get = liftM2 Region get get - - -instance Binary Position where - put (Position a b) = put a >> put b - get = liftM2 Position get get diff --git a/compiler/src/Reporting/Doc.hs b/compiler/src/Reporting/Doc.hs deleted file mode 100644 index 26c15517f9..0000000000 --- a/compiler/src/Reporting/Doc.hs +++ /dev/null @@ -1,431 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE OverloadedStrings #-} -module Reporting.Doc - ( P.Doc - , (P.<+>), (<>) - , P.align, P.cat, P.empty, P.fill, P.fillSep, P.hang - , P.hcat, P.hsep, P.indent, P.sep, P.vcat - , P.red, P.cyan, P.magenta, P.green, P.blue, P.black, P.yellow - , P.dullred, P.dullcyan, P.dullyellow - -- - , fromChars - , fromName - , fromVersion - , fromPackage - , fromInt - -- - , toAnsi - , toString - , toLine - -- - , encode - -- - , stack - , reflow - , commaSep - -- - , toSimpleNote - , toFancyNote - , toSimpleHint - , toFancyHint - -- - , link - , fancyLink - , reflowLink - , makeLink - , makeNakedLink - -- - , args - , moreArgs - , ordinal - , intToOrdinal - , cycle - ) - where - - -import Prelude hiding (cycle) -import qualified Data.List as List -import Data.Monoid ((<>)) -import qualified Data.Name as Name -import qualified System.Console.ANSI.Types as Ansi -import qualified System.Info as Info -import System.IO (Handle) -import qualified Text.PrettyPrint.ANSI.Leijen as P - -import qualified Data.Index as Index -import qualified Elm.Package as Pkg -import qualified Elm.Version as V -import Json.Encode ((==>)) -import qualified Json.Encode as E -import qualified Json.String as Json - - - --- FROM - - -fromChars :: String -> P.Doc -fromChars = - P.text - - -fromName :: Name.Name -> P.Doc -fromName name = - P.text (Name.toChars name) - - -fromVersion :: V.Version -> P.Doc -fromVersion vsn = - P.text (V.toChars vsn) - - -fromPackage :: Pkg.Name -> P.Doc -fromPackage pkg = - P.text (Pkg.toChars pkg) - - -fromInt :: Int -> P.Doc -fromInt n = - P.text (show n) - - - --- TO STRING - - -toAnsi :: Handle -> P.Doc -> IO () -toAnsi handle doc = - P.displayIO handle (P.renderPretty 1 80 doc) - - -toString :: P.Doc -> String -toString doc = - P.displayS (P.renderPretty 1 80 (P.plain doc)) "" - - -toLine :: P.Doc -> String -toLine doc = - P.displayS (P.renderPretty 1 (div maxBound 2) (P.plain doc)) "" - - - --- FORMATTING - - -stack :: [P.Doc] -> P.Doc -stack docs = - P.vcat (List.intersperse "" docs) - - -reflow :: String -> P.Doc -reflow paragraph = - P.fillSep (map P.text (words paragraph)) - - -commaSep :: P.Doc -> (P.Doc -> P.Doc) -> [P.Doc] -> [P.Doc] -commaSep conjunction addStyle names = - case names of - [name] -> - [ addStyle name ] - - [name1,name2] -> - [ addStyle name1, conjunction, addStyle name2 ] - - _ -> - map (\name -> addStyle name <> ",") (init names) - ++ - [ conjunction - , addStyle (last names) - ] - - - --- NOTES - - -toSimpleNote :: String -> P.Doc -toSimpleNote message = - toFancyNote (map P.text (words message)) - - -toFancyNote :: [P.Doc] -> P.Doc -toFancyNote chunks = - P.fillSep (P.underline "Note" <> ":" : chunks) - - - --- HINTS - - -toSimpleHint :: String -> P.Doc -toSimpleHint message = - toFancyHint (map P.text (words message)) - - -toFancyHint :: [P.Doc] -> P.Doc -toFancyHint chunks = - P.fillSep (P.underline "Hint" <> ":" : chunks) - - - --- LINKS - - -link :: String -> String -> String -> String -> P.Doc -link word before fileName after = - P.fillSep $ - (P.underline (P.text word) <> ":") - : map P.text (words before) - ++ P.text (makeLink fileName) - : map P.text (words after) - - -fancyLink :: String -> [P.Doc] -> String -> [P.Doc] -> P.Doc -fancyLink word before fileName after = - P.fillSep $ - (P.underline (P.text word) <> ":") : before ++ P.text (makeLink fileName) : after - - -makeLink :: [Char] -> [Char] -makeLink fileName = - " V.toChars V.compiler <> "/" <> fileName <> ">" - - -makeNakedLink :: [Char] -> [Char] -makeNakedLink fileName = - "https://elm-lang.org/" <> V.toChars V.compiler <> "/" <> fileName - - -reflowLink :: [Char] -> [Char] -> [Char] -> P.Doc -reflowLink before fileName after = - P.fillSep $ - map P.text (words before) - ++ P.text (makeLink fileName) - : map P.text (words after) - - - --- HELPERS - - -args :: Int -> String -args n = - show n <> if n == 1 then " argument" else " arguments" - - -moreArgs :: Int -> String -moreArgs n = - show n <> " more" <> if n == 1 then " argument" else " arguments" - - -ordinal :: Index.ZeroBased -> String -ordinal index = - intToOrdinal (Index.toHuman index) - - -intToOrdinal :: Int -> String -intToOrdinal number = - let - remainder10 = - number `mod` 10 - - remainder100 = - number `mod` 100 - - ending - | remainder100 `elem` [11..13] = "th" - | remainder10 == 1 = "st" - | remainder10 == 2 = "nd" - | remainder10 == 3 = "rd" - | otherwise = "th" - in - show number <> ending - - - -cycle :: Int -> Name.Name -> [Name.Name] -> P.Doc -cycle indent name names = - let - toLn n = cycleLn <> P.dullyellow (fromName n) - in - P.indent indent $ P.vcat $ - cycleTop : List.intersperse cycleMid (toLn name : map toLn names) ++ [ cycleEnd ] - - -cycleTop, cycleLn, cycleMid, cycleEnd :: P.Doc -cycleTop = if isWindows then "+-----+" else "┌─────┐" -cycleLn = if isWindows then "| " else "│ " -cycleMid = if isWindows then "| |" else "│ ↓" -cycleEnd = if isWindows then "+-<---+" else "└─────┘" - - -isWindows :: Bool -isWindows = - Info.os == "mingw32" - - - --- JSON - - -encode :: P.Doc -> E.Value -encode doc = - E.array (toJsonHelp noStyle [] (P.renderPretty 1 80 doc)) - - -data Style = - Style - { _bold :: Bool - , _underline :: Bool - , _color :: Maybe Color - } - - -noStyle :: Style -noStyle = - Style False False Nothing - - -data Color - = Red - | RED - | Magenta - | MAGENTA - | Yellow - | YELLOW - | Green - | GREEN - | Cyan - | CYAN - | Blue - | BLUE - | Black - | BLACK - | White - | WHITE - - -toJsonHelp :: Style -> [String] -> P.SimpleDoc -> [E.Value] -toJsonHelp style revChunks simpleDoc = - case simpleDoc of - P.SFail -> - error $ - "according to the main implementation, @SFail@ can not\ - \ appear uncaught in a rendered @SimpleDoc@" - - P.SEmpty -> - [ encodeChunks style revChunks ] - - P.SChar char rest -> - toJsonHelp style ([char] : revChunks) rest - - P.SText _ string rest -> - toJsonHelp style (string : revChunks) rest - - P.SLine indent rest -> - toJsonHelp style (replicate indent ' ' : "\n" : revChunks) rest - - P.SSGR sgrs rest -> - encodeChunks style revChunks : toJsonHelp (sgrToStyle sgrs style) [] rest - - -sgrToStyle :: [Ansi.SGR] -> Style -> Style -sgrToStyle sgrs style@(Style bold underline color) = - case sgrs of - [] -> - style - - sgr : rest -> - sgrToStyle rest $ - case sgr of - Ansi.Reset -> noStyle - Ansi.SetConsoleIntensity i -> Style (isBold i) underline color - Ansi.SetItalicized _ -> style - Ansi.SetUnderlining u -> Style bold (isUnderline u) color - Ansi.SetBlinkSpeed _ -> style - Ansi.SetVisible _ -> style - Ansi.SetSwapForegroundBackground _ -> style - Ansi.SetColor l i c -> Style bold underline (toColor l i c) - Ansi.SetRGBColor _ _ -> style - - -isBold :: Ansi.ConsoleIntensity -> Bool -isBold intensity = - case intensity of - Ansi.BoldIntensity -> True - Ansi.FaintIntensity -> False - Ansi.NormalIntensity -> False - - -isUnderline :: Ansi.Underlining -> Bool -isUnderline underlining = - case underlining of - Ansi.SingleUnderline -> True - Ansi.DoubleUnderline -> False - Ansi.NoUnderline -> False - - -toColor :: Ansi.ConsoleLayer -> Ansi.ColorIntensity -> Ansi.Color -> Maybe Color -toColor layer intensity color = - case layer of - Ansi.Background -> - Nothing - - Ansi.Foreground -> - let - pick dull vivid = - case intensity of - Ansi.Dull -> dull - Ansi.Vivid -> vivid - in - Just $ - case color of - Ansi.Red -> pick Red RED - Ansi.Magenta -> pick Magenta MAGENTA - Ansi.Yellow -> pick Yellow YELLOW - Ansi.Green -> pick Green GREEN - Ansi.Cyan -> pick Cyan CYAN - Ansi.Blue -> pick Blue BLUE - Ansi.White -> pick White WHITE - Ansi.Black -> pick Black BLACK - - -encodeChunks :: Style -> [String] -> E.Value -encodeChunks (Style bold underline color) revChunks = - let - chars = concat (reverse revChunks) - in - case color of - Nothing | not bold && not underline -> - E.chars chars - - _ -> - E.object - [ "bold" ==> E.bool bold - , "underline" ==> E.bool underline - , "color" ==> maybe E.null encodeColor color - , "string" ==> E.chars chars - ] - - -encodeColor :: Color -> E.Value -encodeColor color = - E.string $ Json.fromChars $ - case color of - Red -> "red" - RED -> "RED" - Magenta -> "magenta" - MAGENTA -> "MAGENTA" - Yellow -> "yellow" - YELLOW -> "YELLOW" - Green -> "green" - GREEN -> "GREEN" - Cyan -> "cyan" - CYAN -> "CYAN" - Blue -> "blue" - BLUE -> "BLUE" - Black -> "black" - BLACK -> "BLACK" - White -> "white" - WHITE -> "WHITE" diff --git a/compiler/src/Reporting/Error.hs b/compiler/src/Reporting/Error.hs deleted file mode 100644 index 2658012ac1..0000000000 --- a/compiler/src/Reporting/Error.hs +++ /dev/null @@ -1,210 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE OverloadedStrings #-} -module Reporting.Error - ( Module(..) - , Error(..) - , toDoc - , toJson - ) - where - - -import qualified Data.ByteString as B -import qualified Data.NonEmptyList as NE -import qualified Data.OneOrMore as OneOrMore -import qualified System.FilePath as FP - -import qualified Elm.ModuleName as ModuleName -import qualified File -import qualified Json.Encode as E -import Json.Encode ((==>)) -import qualified Reporting.Annotation as A -import qualified Reporting.Doc as D -import qualified Reporting.Error.Canonicalize as Canonicalize -import qualified Reporting.Error.Docs as Docs -import qualified Reporting.Error.Import as Import -import qualified Reporting.Error.Main as Main -import qualified Reporting.Error.Pattern as Pattern -import qualified Reporting.Error.Syntax as Syntax -import qualified Reporting.Error.Type as Type -import qualified Reporting.Render.Code as Code -import qualified Reporting.Render.Type.Localizer as L -import qualified Reporting.Report as Report - - - --- MODULE - - -data Module = - Module - { _name :: ModuleName.Raw - , _absolutePath :: FilePath - , _modificationTime :: File.Time - , _source :: B.ByteString - , _error :: Error - } - - - --- ERRORS - - -data Error - = BadSyntax Syntax.Error - | BadImports (NE.List Import.Error) - | BadNames (OneOrMore.OneOrMore Canonicalize.Error) - | BadTypes L.Localizer (NE.List Type.Error) - | BadMains L.Localizer (OneOrMore.OneOrMore Main.Error) - | BadPatterns (NE.List Pattern.Error) - | BadDocs Docs.Error - - - --- TO REPORT - - -toReports :: Code.Source -> Error -> NE.List Report.Report -toReports source err = - case err of - BadSyntax syntaxError -> - NE.List (Syntax.toReport source syntaxError) [] - - BadImports errs -> - fmap (Import.toReport source) errs - - BadNames errs -> - fmap (Canonicalize.toReport source) (OneOrMore.destruct NE.List errs) - - BadTypes localizer errs -> - fmap (Type.toReport source localizer) errs - - BadMains localizer errs -> - fmap (Main.toReport localizer source) (OneOrMore.destruct NE.List errs) - - BadPatterns errs -> - fmap (Pattern.toReport source) errs - - BadDocs docsErr -> - Docs.toReports source docsErr - - - --- TO DOC - - -toDoc :: FilePath -> Module -> [Module] -> D.Doc -toDoc root err errs = - let - (NE.List m ms) = NE.sortBy _modificationTime (NE.List err errs) - in - D.vcat (toDocHelp root m ms) - - -toDocHelp :: FilePath -> Module -> [Module] -> [D.Doc] -toDocHelp root module1 modules = - case modules of - [] -> - [moduleToDoc root module1 - ,"" - ] - - module2 : otherModules -> - moduleToDoc root module1 - : toSeparator module1 module2 - : toDocHelp root module2 otherModules - - -toSeparator :: Module -> Module -> D.Doc -toSeparator beforeModule afterModule = - let - before = ModuleName.toChars (_name beforeModule) ++ " ↑ " - after = " ↓ " ++ ModuleName.toChars (_name afterModule) - in - D.dullred $ D.vcat $ - [ D.indent (80 - length before) (D.fromChars before) - , "====o======================================================================o====" - , D.fromChars after - , "" - , "" - ] - - - --- MODULE TO DOC - - -moduleToDoc :: FilePath -> Module -> D.Doc -moduleToDoc root (Module _ absolutePath _ source err) = - let - reports = - toReports (Code.toSource source) err - - relativePath = - FP.makeRelative root absolutePath - in - D.vcat $ map (reportToDoc relativePath) (NE.toList reports) - - -reportToDoc :: FilePath -> Report.Report -> D.Doc -reportToDoc relativePath (Report.Report title _ _ message) = - D.vcat - [ toMessageBar title relativePath - , "" - , message - , "" - ] - - -toMessageBar :: String -> FilePath -> D.Doc -toMessageBar title filePath = - let - usedSpace = - 4 + length title + 1 + length filePath - in - D.dullcyan $ D.fromChars $ - "-- " ++ title - ++ " " ++ replicate (max 1 (80 - usedSpace)) '-' - ++ " " ++ filePath - - - --- TO JSON - - -toJson :: Module -> E.Value -toJson (Module name path _ source err) = - let - reports = - toReports (Code.toSource source) err - in - E.object - [ "path" ==> E.chars path - , "name" ==> E.name name - , "problems" ==> E.array (map reportToJson (NE.toList reports)) - ] - - -reportToJson :: Report.Report -> E.Value -reportToJson (Report.Report title region _sgstns message) = - E.object - [ "title" ==> E.chars title - , "region" ==> encodeRegion region - , "message" ==> D.encode message - ] - - -encodeRegion :: A.Region -> E.Value -encodeRegion (A.Region (A.Position sr sc) (A.Position er ec)) = - E.object - [ "start" ==> - E.object - [ "line" ==> E.int (fromIntegral sr) - , "column" ==> E.int (fromIntegral sc) - ] - , "end" ==> - E.object - [ "line" ==> E.int (fromIntegral er) - , "column" ==> E.int (fromIntegral ec) - ] - ] diff --git a/compiler/src/Reporting/Error/Canonicalize.hs b/compiler/src/Reporting/Error/Canonicalize.hs deleted file mode 100644 index cee18997af..0000000000 --- a/compiler/src/Reporting/Error/Canonicalize.hs +++ /dev/null @@ -1,1256 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE OverloadedStrings #-} -module Reporting.Error.Canonicalize - ( Error(..) - , BadArityContext(..) - , InvalidPayload(..) - , PortProblem(..) - , DuplicatePatternContext(..) - , PossibleNames(..) - , VarKind(..) - , toReport - ) - where - - -import qualified Data.Char as Char -import qualified Data.Map as Map -import qualified Data.Name as Name -import qualified Data.Set as Set - -import qualified AST.Canonical as Can -import qualified AST.Source as Src -import qualified Data.Index as Index -import qualified Elm.ModuleName as ModuleName -import qualified Reporting.Annotation as A -import qualified Reporting.Doc as D -import Reporting.Doc (Doc, (<+>), (<>)) -import qualified Reporting.Render.Code as Code -import qualified Reporting.Render.Type as RT -import qualified Reporting.Report as Report -import qualified Reporting.Suggest as Suggest - - - --- CANONICALIZATION ERRORS - - -data Error - = AnnotationTooShort A.Region Name.Name Index.ZeroBased Int - | AmbiguousVar A.Region (Maybe Name.Name) Name.Name [ModuleName.Canonical] - | AmbiguousType A.Region (Maybe Name.Name) Name.Name [ModuleName.Canonical] - | AmbiguousVariant A.Region (Maybe Name.Name) Name.Name [ModuleName.Canonical] - | AmbiguousBinop A.Region Name.Name [ModuleName.Canonical] - | BadArity A.Region BadArityContext Name.Name Int Int - | Binop A.Region Name.Name Name.Name - | DuplicateDecl Name.Name A.Region A.Region - | DuplicateType Name.Name A.Region A.Region - | DuplicateCtor Name.Name A.Region A.Region - | DuplicateBinop Name.Name A.Region A.Region - | DuplicateField Name.Name A.Region A.Region - | DuplicateAliasArg Name.Name Name.Name A.Region A.Region - | DuplicateUnionArg Name.Name Name.Name A.Region A.Region - | DuplicatePattern DuplicatePatternContext Name.Name A.Region A.Region - | EffectNotFound A.Region Name.Name - | EffectFunctionNotFound A.Region Name.Name - | ExportDuplicate Name.Name A.Region A.Region - | ExportNotFound A.Region VarKind Name.Name [Name.Name] - | ExportOpenAlias A.Region Name.Name - | ImportCtorByName A.Region Name.Name Name.Name - | ImportNotFound A.Region Name.Name [ModuleName.Canonical] - | ImportOpenAlias A.Region Name.Name - | ImportExposingNotFound A.Region ModuleName.Canonical Name.Name [Name.Name] - | NotFoundVar A.Region (Maybe Name.Name) Name.Name PossibleNames - | NotFoundType A.Region (Maybe Name.Name) Name.Name PossibleNames - | NotFoundVariant A.Region (Maybe Name.Name) Name.Name PossibleNames - | NotFoundBinop A.Region Name.Name (Set.Set Name.Name) - | PatternHasRecordCtor A.Region Name.Name - | PortPayloadInvalid A.Region Name.Name Can.Type InvalidPayload - | PortTypeInvalid A.Region Name.Name PortProblem - | RecursiveAlias A.Region Name.Name [Name.Name] Src.Type [Name.Name] - | RecursiveDecl A.Region Name.Name [Name.Name] - | RecursiveLet (A.Located Name.Name) [Name.Name] - | Shadowing Name.Name A.Region A.Region - | TupleLargerThanThree A.Region - | TypeVarsUnboundInUnion A.Region Name.Name [Name.Name] (Name.Name, A.Region) [(Name.Name, A.Region)] - | TypeVarsMessedUpInAlias A.Region Name.Name [Name.Name] [(Name.Name, A.Region)] [(Name.Name, A.Region)] - - -data BadArityContext - = TypeArity - | PatternArity - - -data DuplicatePatternContext - = DPLambdaArgs - | DPFuncArgs Name.Name - | DPCaseBranch - | DPLetBinding - | DPDestruct - - -data InvalidPayload - = ExtendedRecord - | Function - | TypeVariable Name.Name - | UnsupportedType Name.Name - - -data PortProblem - = CmdNoArg - | CmdExtraArgs Int - | CmdBadMsg - | SubBad - | NotCmdOrSub - - -data PossibleNames = - PossibleNames - { _locals :: Set.Set Name.Name - , _quals :: Map.Map Name.Name (Set.Set Name.Name) - } - - - --- KIND - - -data VarKind - = BadOp - | BadVar - | BadPattern - | BadType - - -toKindInfo :: VarKind -> Name.Name -> ( Doc, Doc, Doc ) -toKindInfo kind name = - case kind of - BadOp -> - ( "an", "operator", "(" <> D.fromName name <> ")" ) - - BadVar -> - ( "a", "value", "`" <> D.fromName name <> "`" ) - - BadPattern -> - ( "a", "pattern", "`" <> D.fromName name <> "`" ) - - BadType -> - ( "a", "type", "`" <> D.fromName name <> "`" ) - - - --- TO REPORT - - -toReport :: Code.Source -> Error -> Report.Report -toReport source err = - case err of - AnnotationTooShort region name index leftovers -> - let - numTypeArgs = Index.toMachine index - numDefArgs = numTypeArgs + leftovers - in - Report.Report "BAD TYPE ANNOTATION" region [] $ - Code.toSnippet source region Nothing - ( - D.reflow $ - "The type annotation for `" <> Name.toChars name <> "` says it can accept " - <> D.args numTypeArgs <> ", but the definition says it has " - <> D.args numDefArgs <> ":" - , - D.reflow $ - "Is the type annotation missing something? Should some argument" - <> (if leftovers == 1 then "" else "s") - <> " be deleted? Maybe some parentheses are missing?" - ) - - AmbiguousVar region maybePrefix name possibleHomes -> - ambiguousName source region maybePrefix name possibleHomes "variable" - - AmbiguousType region maybePrefix name possibleHomes -> - ambiguousName source region maybePrefix name possibleHomes "type" - - AmbiguousVariant region maybePrefix name possibleHomes -> - ambiguousName source region maybePrefix name possibleHomes "variant" - - AmbiguousBinop region name possibleHomes -> - ambiguousName source region Nothing name possibleHomes "operator" - - BadArity region badArityContext name expected actual -> - let - thing = - case badArityContext of - TypeArity -> "type" - PatternArity -> "variant" - in - if actual < expected then - Report.Report "TOO FEW ARGS" region [] $ - Code.toSnippet source region Nothing - ( - D.reflow $ - "The `" <> Name.toChars name <> "` " <> thing <> " needs " - <> D.args expected <> ", but I see " <> show actual <> " instead:" - , - D.reflow $ - "What is missing? Are some parentheses misplaced?" - ) - - else - Report.Report "TOO MANY ARGS" region [] $ - Code.toSnippet source region Nothing - ( - D.reflow $ - "The `" <> Name.toChars name <> "` " <> thing <> " needs " - <> D.args expected <> ", but I see " <> show actual <> " instead:" - , - if actual - expected == 1 then - "Which is the extra one? Maybe some parentheses are missing?" - else - "Which are the extra ones? Maybe some parentheses are missing?" - ) - - Binop region op1 op2 -> - Report.Report "INFIX PROBLEM" region [] $ - Code.toSnippet source region Nothing - ( - D.reflow $ - "You cannot mix (" <> Name.toChars op1 <> ") and (" <> Name.toChars op2 <> ") without parentheses." - , - D.reflow - "I do not know how to group these expressions. Add parentheses for me!" - ) - - DuplicateDecl name r1 r2 -> - nameClash source r1 r2 $ - "This file has multiple `" <> Name.toChars name <> "` declarations." - - DuplicateType name r1 r2 -> - nameClash source r1 r2 $ - "This file defines multiple `" <> Name.toChars name <> "` types." - - DuplicateCtor name r1 r2 -> - nameClash source r1 r2 $ - "This file defines multiple `" <> Name.toChars name <> "` type constructors." - - DuplicateBinop name r1 r2 -> - nameClash source r1 r2 $ - "This file defines multiple (" <> Name.toChars name <> ") operators." - - DuplicateField name r1 r2 -> - nameClash source r1 r2 $ - "This record has multiple `" <> Name.toChars name <> "` fields." - - DuplicateAliasArg typeName name r1 r2 -> - nameClash source r1 r2 $ - "The `" <> Name.toChars typeName <> "` type alias has multiple `" <> Name.toChars name <> "` type variables." - - DuplicateUnionArg typeName name r1 r2 -> - nameClash source r1 r2 $ - "The `" <> Name.toChars typeName <> "` type has multiple `" <> Name.toChars name <> "` type variables." - - DuplicatePattern context name r1 r2 -> - nameClash source r1 r2 $ - case context of - DPLambdaArgs -> - "This anonymous function has multiple `" <> Name.toChars name <> "` arguments." - - DPFuncArgs funcName -> - "The `" <> Name.toChars funcName <> "` function has multiple `" <> Name.toChars name <> "` arguments." - - DPCaseBranch -> - "This `case` pattern has multiple `" <> Name.toChars name <> "` variables." - - DPLetBinding -> - "This `let` expression defines `" <> Name.toChars name <> "` more than once!" - - DPDestruct -> - "This pattern contains multiple `" <> Name.toChars name <> "` variables." - - EffectNotFound region name -> - Report.Report "EFFECT PROBLEM" region [] $ - Code.toSnippet source region Nothing - ( - D.reflow $ - "You have declared that `" ++ Name.toChars name ++ "` is an effect type:" - , - D.reflow $ - "But I cannot find a custom type named `" ++ Name.toChars name ++ "` in this file!" - ) - - EffectFunctionNotFound region name -> - Report.Report "EFFECT PROBLEM" region [] $ - Code.toSnippet source region Nothing - ( - D.reflow $ - "This kind of effect module must define a `" ++ Name.toChars name ++ "` function." - , - D.reflow $ - "But I cannot find `" ++ Name.toChars name ++ "` in this file!" - ) - - - ExportDuplicate name r1 r2 -> - let - messageThatEndsWithPunctuation = - "You are trying to expose `" <> Name.toChars name <> "` multiple times!" - in - Report.Report "REDUNDANT EXPORT" r2 [] $ - Code.toPair source r1 r2 - ( - D.reflow messageThatEndsWithPunctuation - , - "Remove one of them and you should be all set!" - ) - ( - D.reflow (messageThatEndsWithPunctuation <> " Once here:") - , - "And again right here:" - , - "Remove one of them and you should be all set!" - ) - - ExportNotFound region kind rawName possibleNames -> - let - suggestions = - map Name.toChars $ take 4 $ - Suggest.sort (Name.toChars rawName) Name.toChars possibleNames - in - Report.Report "UNKNOWN EXPORT" region suggestions $ - let (a, thing, name) = toKindInfo kind rawName in - D.stack - [ D.fillSep - ["You","are","trying","to","expose",a,thing,"named" - ,name,"but","I","cannot","find","its","definition." - ] - , case map D.fromChars suggestions of - [] -> - D.reflow $ - "I do not see any super similar names in this file. Is the definition missing?" - - [alt] -> - D.fillSep ["Maybe","you","want",D.dullyellow alt,"instead?"] - - alts -> - D.stack - [ "These names seem close though:" - , D.indent 4 $ D.vcat $ map D.dullyellow alts - ] - ] - - ExportOpenAlias region name -> - Report.Report "BAD EXPORT" region [] $ - Code.toSnippet source region Nothing - ( - D.reflow $ - "The (..) syntax is for exposing variants of a custom type. It cannot be used with a type alias like `" - ++ Name.toChars name ++ "` though." - , - D.reflow $ - "Remove the (..) and you should be fine!" - ) - - ImportCtorByName region ctor tipe -> - Report.Report "BAD IMPORT" region [] $ - Code.toSnippet source region Nothing - ( - D.reflow $ - "You are trying to import the `" <> Name.toChars ctor - <> "` variant by name:" - , - D.fillSep - ["Try","importing",D.green (D.fromName tipe <> "(..)"),"instead." - ,"The","dots","mean","“expose","the",D.fromName tipe,"type","and" - ,"all","its","variants","so","it","gives","you","access","to" - , D.fromName ctor <> "." - ] - ) - - ImportNotFound region name _ -> - -- - -- NOTE: this should always be detected by `builder` - -- So this error should never actually get printed out. - -- - Report.Report "UNKNOWN IMPORT" region [] $ - Code.toSnippet source region Nothing - ( - D.reflow $ - "I could not find a `" <> Name.toChars name <> "` module to import!" - , - mempty - ) - - ImportOpenAlias region name -> - Report.Report "BAD IMPORT" region [] $ - Code.toSnippet source region Nothing - ( - D.reflow $ - "The `" <> Name.toChars name <> "` type alias cannot be followed by (..) like this:" - , - D.reflow $ - "Remove the (..) and it should work." - ) - - ImportExposingNotFound region (ModuleName.Canonical _ home) value possibleNames -> - let - suggestions = - map Name.toChars $ take 4 $ - Suggest.sort (Name.toChars home) Name.toChars possibleNames - in - Report.Report "BAD IMPORT" region suggestions $ - Code.toSnippet source region Nothing - ( - D.reflow $ - "The `" <> Name.toChars home - <> "` module does not expose `" - <> Name.toChars value <> "`:" - , - case map D.fromChars suggestions of - [] -> - "I cannot find any super similar exposed names. Maybe it is private?" - - [alt] -> - D.fillSep ["Maybe","you","want",D.dullyellow alt,"instead?"] - - alts -> - D.stack - [ "These names seem close though:" - , D.indent 4 $ D.vcat $ map D.dullyellow alts - ] - ) - - NotFoundVar region prefix name possibleNames -> - notFound source region prefix name "variable" possibleNames - - NotFoundType region prefix name possibleNames -> - notFound source region prefix name "type" possibleNames - - NotFoundVariant region prefix name possibleNames -> - notFound source region prefix name "variant" possibleNames - - NotFoundBinop region op locals -> - if op == "===" then - Report.Report "UNKNOWN OPERATOR" region ["=="] $ - Code.toSnippet source region Nothing - ( - "Elm does not have a (===) operator like JavaScript." - , - "Switch to (==) instead." - ) - - else if op == "!=" || op == "!==" then - Report.Report "UNKNOWN OPERATOR" region ["/="] $ - Code.toSnippet source region Nothing - ( - D.reflow $ - "Elm uses a different name for the “not equal” operator:" - , - D.stack - [ D.reflow "Switch to (/=) instead." - , D.toSimpleNote $ - "Our (/=) operator is supposed to look like a real “not equal” sign (≠). I hope that history will remember (" - ++ Name.toChars op ++ ") as a weird and temporary choice." - ] - ) - - else if op == "**" then - Report.Report "UNKNOWN OPERATOR" region ["^","*"] $ - Code.toSnippet source region Nothing - ( - D.reflow $ - "I do not recognize the (**) operator:" - , - D.reflow $ - "Switch to (^) for exponentiation. Or switch to (*) for multiplication." - ) - - else if op == "%" then - Report.Report "UNKNOWN OPERATOR" region [] $ - Code.toSnippet source region Nothing - ( - D.reflow $ - "Elm does not use (%) as the remainder operator:" - , - D.stack - [ D.reflow $ - "If you want the behavior of (%) like in JavaScript, switch to:\ - \ " - , D.reflow $ - "If you want modular arithmetic like in math, switch to:\ - \ " - , D.reflow $ - "The difference is how things work when negative numbers are involved." - ] - ) - - else - let - suggestions = - map Name.toChars $ take 2 $ - Suggest.sort (Name.toChars op) Name.toChars (Set.toList locals) - - format altOp = - D.green $ "(" <> altOp <> ")" - in - Report.Report "UNKNOWN OPERATOR" region suggestions $ - Code.toSnippet source region Nothing - ( - D.reflow $ - "I do not recognize the (" ++ Name.toChars op ++ ") operator." - , - D.fillSep $ - ["Is","there","an","`import`","and","`exposing`","entry","for","it?"] - ++ - case map D.fromChars suggestions of - [] -> - [] - - alts -> - ["Maybe","you","want"] ++ D.commaSep "or" format alts ++ ["instead?"] - ) - - PatternHasRecordCtor region name -> - Report.Report "BAD PATTERN" region [] $ - Code.toSnippet source region Nothing - ( - D.reflow $ - "You can construct records by using `" <> Name.toChars name - <> "` as a function, but it is not available in pattern matching like this:" - , - D.reflow $ - "I recommend matching the record as a variable and unpacking it later." - ) - - PortPayloadInvalid region portName _badType invalidPayload -> - let - formatDetails (aBadKindOfThing, elaboration) = - Report.Report "PORT ERROR" region [] $ - Code.toSnippet source region Nothing - ( - D.reflow $ - "The `" <> Name.toChars portName <> "` port is trying to transmit " <> aBadKindOfThing <> ":" - , - D.stack - [ elaboration - , D.link "Hint" - "Ports are not a traditional FFI, so if you have tons of annoying ports, definitely read" - "ports" - "to learn how they are meant to work. They require a different mindset!" - ] - ) - in - formatDetails $ - case invalidPayload of - ExtendedRecord -> - ( - "an extended record" - , - D.reflow $ - "But the exact shape of the record must be known at compile time. No type variables!" - ) - - Function -> - ( - "a function" - , - D.reflow $ - "But functions cannot be sent in and out ports. If we allowed functions in from JS\ - \ they may perform some side-effects. If we let functions out, they could produce\ - \ incorrect results because Elm optimizations assume there are no side-effects." - ) - - - TypeVariable name -> - ( - "an unspecified type" - , - D.reflow $ - "But type variables like `" <> Name.toChars name <> "` cannot flow through ports.\ - \ I need to know exactly what type of data I am getting, so I can guarantee that\ - \ unexpected data cannot sneak in and crash the Elm program." - ) - - UnsupportedType name -> - ( - "a `" <> Name.toChars name <> "` value" - , - D.stack - [ D.reflow $ "I cannot handle that. The types that CAN flow in and out of Elm include:" - , D.indent 4 $ - D.reflow $ - "Ints, Floats, Bools, Strings, Maybes, Lists, Arrays,\ - \ tuples, records, and JSON values." - , D.reflow $ - "Since JSON values can flow through, you can use JSON encoders and decoders\ - \ to allow other types through as well. More advanced users often just do\ - \ everything with encoders and decoders for more control and better errors." - ] - ) - - PortTypeInvalid region name portProblem -> - let - formatDetails (before, after) = - Report.Report "BAD PORT" region [] $ - Code.toSnippet source region Nothing $ - ( - D.reflow before - , - D.stack - [ after - , D.link "Hint" "Read" "ports" - "for more advice. For example, do not end up with one port per JS function!" - ] - ) - in - formatDetails $ - case portProblem of - CmdNoArg -> - ( - "The `" <> Name.toChars name <> "` port cannot be just a command." - , - D.reflow $ - "It can be (() -> Cmd msg) if you just need to trigger a JavaScript\ - \ function, but there is often a better way to set things up." - ) - - CmdExtraArgs n -> - ( - "The `" <> Name.toChars name <> "` port can only send ONE value out to JavaScript." - , - let - theseItemsInSomething - | n == 2 = "both of these items into a tuple or record" - | n == 3 = "these " ++ show n ++ " items into a tuple or record" - | True = "these " ++ show n ++ " items into a record" - in - D.reflow $ - "You can put " ++ theseItemsInSomething ++ " to send them out though." - ) - - CmdBadMsg -> - ( - "The `" <> Name.toChars name <> "` port cannot send any messages to the `update` function." - , - D.reflow $ - "It must produce a (Cmd msg) type. Notice the lower case `msg` type\ - \ variable. The command will trigger some JS code, but it will not send\ - \ anything particular back to Elm." - ) - - SubBad -> - ( "There is something off about this `" <> Name.toChars name <> "` port declaration." - , - D.stack - [ D.reflow $ - "To receive messages from JavaScript, you need to define a port like this:" - , D.indent 4 $ D.dullyellow $ D.fromChars $ - "port " <> Name.toChars name <> " : (Int -> msg) -> Sub msg" - , D.reflow $ - "Now every time JS sends an `Int` to this port, it is converted to a `msg`.\ - \ And if you subscribe, those `msg` values will be piped into your `update`\ - \ function. The only thing you can customize here is the `Int` type." - ] - ) - - NotCmdOrSub -> - ( - "I am confused about the `" <> Name.toChars name <> "` port declaration." - , - D.reflow $ - "Ports need to produce a command (Cmd) or a subscription (Sub) but\ - \ this is neither. I do not know how to handle this." - ) - - RecursiveAlias region name args tipe others -> - aliasRecursionReport source region name args tipe others - - RecursiveDecl region name names -> - let - makeTheory question details = - D.fillSep $ map (D.dullyellow . D.fromChars) (words question) ++ map D.fromChars (words details) - in - Report.Report "CYCLIC DEFINITION" region [] $ - Code.toSnippet source region Nothing $ - case names of - [] -> - ( - D.reflow $ - "The `" <> Name.toChars name <> "` value is defined directly in terms of itself, causing an infinite loop." - , - D.stack - [ makeTheory "Are you are trying to mutate a variable?" $ - "Elm does not have mutation, so when I see " ++ Name.toChars name - ++ " defined in terms of " ++ Name.toChars name - ++ ", I treat it as a recursive definition. Try giving the new value a new name!" - , makeTheory "Maybe you DO want a recursive value?" $ - "To define " ++ Name.toChars name ++ " we need to know what " ++ Name.toChars name - ++ " is, so let’s expand it. Wait, but now we need to know what " ++ Name.toChars name - ++ " is, so let’s expand it... This will keep going infinitely!" - , D.link "Hint" - "The root problem is often a typo in some variable name, but I recommend reading" - "bad-recursion" - "for more detailed advice, especially if you actually do need a recursive value." - ] - ) - - _:_ -> - ( - D.reflow $ - "The `" <> Name.toChars name <> "` definition is causing a very tricky infinite loop." - , - D.stack - [ D.reflow $ - "The `" <> Name.toChars name - <> "` value depends on itself through the following chain of definitions:" - , D.cycle 4 name names - , D.link "Hint" - "The root problem is often a typo in some variable name, but I recommend reading" - "bad-recursion" - "for more detailed advice, especially if you actually do want mutually recursive values." - ] - ) - - RecursiveLet (A.At region name) names -> - Report.Report "CYCLIC VALUE" region [] $ - Code.toSnippet source region Nothing $ - case names of - [] -> - let - makeTheory question details = - D.fillSep $ map (D.dullyellow . D.fromChars) (words question) ++ map D.fromChars (words details) - in - ( - D.reflow $ - "The `" <> Name.toChars name <> "` value is defined directly in terms of itself, causing an infinite loop." - , - D.stack - [ makeTheory "Are you are trying to mutate a variable?" $ - "Elm does not have mutation, so when I see " ++ Name.toChars name - ++ " defined in terms of " ++ Name.toChars name - ++ ", I treat it as a recursive definition. Try giving the new value a new name!" - , makeTheory "Maybe you DO want a recursive value?" $ - "To define " ++ Name.toChars name ++ " we need to know what " ++ Name.toChars name - ++ " is, so let’s expand it. Wait, but now we need to know what " ++ Name.toChars name - ++ " is, so let’s expand it... This will keep going infinitely!" - , D.link "Hint" - "The root problem is often a typo in some variable name, but I recommend reading" - "bad-recursion" - "for more detailed advice, especially if you actually do need a recursive value." - ] - ) - - _ -> - ( - D.reflow $ - "I do not allow cyclic values in `let` expressions." - , - D.stack - [ D.reflow $ - "The `" <> Name.toChars name - <> "` value depends on itself through the following chain of definitions:" - , D.cycle 4 name names - , D.link "Hint" - "The root problem is often a typo in some variable name, but I recommend reading" - "bad-recursion" - "for more detailed advice, especially if you actually do want mutually recursive values." - ] - ) - - Shadowing name r1 r2 -> - Report.Report "SHADOWING" r2 [] $ - Code.toPair source r1 r2 - ( "These variables cannot have the same name:" - , advice - ) - ( D.reflow $ "The name `" <> Name.toChars name <> "` is first defined here:" - , "But then it is defined AGAIN over here:" - , advice - ) - where - advice = - D.stack - [ D.reflow $ - "Think of a more helpful name for one of them and you should be all set!" - , D.link "Note" - "Linters advise against shadowing, so Elm makes “best practices” the default. Read" - "shadowing" - "for more details on this choice." - ] - - TupleLargerThanThree region -> - Report.Report "BAD TUPLE" region [] $ - Code.toSnippet source region Nothing - ( - "I only accept tuples with two or three items. This has too many:" - , - D.stack - [ D.reflow $ - "I recommend switching to records. Each item will be named, and you can use\ - \ the `point.x` syntax to access them." - - , D.link "Note" "Read" "tuples" - - "for more comprehensive advice on working with large chunks of data in Elm." - ] - ) - - TypeVarsUnboundInUnion unionRegion typeName allVars unbound unbounds -> - unboundTypeVars source unionRegion ["type"] typeName allVars unbound unbounds - - TypeVarsMessedUpInAlias aliasRegion typeName allVars unusedVars unboundVars -> - case (unusedVars, unboundVars) of - (unused:unuseds, []) -> - let - backQuote name = - "`" <> D.fromName name <> "`" - - allUnusedNames = - map fst unusedVars - - (title, subRegion, overview, stuff) = - case unuseds of - [] -> - ("UNUSED TYPE VARIABLE" - , Just (snd unused) - , ["Type","alias",backQuote typeName,"does","not","use","the" - ,backQuote (fst unused),"type","variable." - ] - , [D.dullyellow (backQuote (fst unused))] - ) - - _:_ -> - ( "UNUSED TYPE VARIABLES" - , Nothing - , ["Type","variables"] - ++ D.commaSep "and" id (map D.fromName allUnusedNames) - ++ ["are","unused","in","the",backQuote typeName,"definition."] - , D.commaSep "and" D.dullyellow (map D.fromName allUnusedNames) - ) - in - Report.Report title aliasRegion [] $ - Code.toSnippet source aliasRegion subRegion - ( - D.fillSep overview - , - D.stack - [ D.fillSep $ - ["I","recommend","removing"] ++ stuff ++ ["from","the","declaration,","like","this:"] - , D.indent 4 $ D.hsep $ - ["type","alias",D.green (D.fromName typeName)] - ++ map D.fromName (filter (`notElem` allUnusedNames) allVars) - ++ ["=", "..."] - , D.reflow $ - "Why? Well, if I allowed `type alias Height a = Float` I would need to answer\ - \ some weird questions. Is `Height Bool` the same as `Float`? Is `Height Bool`\ - \ the same as `Height Int`? My solution is to not need to ask them!" - ] - ) - - ([], unbound:unbounds) -> - unboundTypeVars source aliasRegion ["type","alias"] typeName allVars unbound unbounds - - (_, _) -> - let - unused = map fst unusedVars - unbound = map fst unboundVars - - theseAreUsed = - case unbound of - [x] -> - ["Type","variable",D.dullyellow ("`" <> D.fromName x <> "`"),"appears" - ,"in","the","definition,","but","I","do","not","see","it","declared." - ] - - _ -> - ["Type","variables"] - ++ D.commaSep "and" D.dullyellow (map D.fromName unbound) - ++ ["are","used","in","the","definition,","but","I","do","not","see","them","declared."] - - butTheseAreUnused = - case unused of - [x] -> - ["Likewise,","type","variable" - ,D.dullyellow ("`" <> D.fromName x <> "`") - ,"is","delared,","but","not","used." - ] - - _ -> - ["Likewise,","type","variables"] - ++ D.commaSep "and" D.dullyellow (map D.fromName unused) - ++ ["are","delared,","but","not","used."] - - in - Report.Report "TYPE VARIABLE PROBLEMS" aliasRegion [] $ - Code.toSnippet source aliasRegion Nothing - ( - D.reflow $ - "Type alias `" <> Name.toChars typeName <> "` has some type variable problems." - , - D.stack - [ D.fillSep $ theseAreUsed ++ butTheseAreUnused - , D.reflow $ - "My guess is that a definition like this will work better:" - , D.indent 4 $ D.hsep $ - ["type", "alias", D.fromName typeName] - ++ map D.fromName (filter (`notElem` unused) allVars) - ++ map (D.green . D.fromName) unbound - ++ ["=", "..."] - ] - ) - - - --- BAD TYPE VARIABLES - - -unboundTypeVars :: Code.Source -> A.Region -> [D.Doc] -> Name.Name -> [Name.Name] -> (Name.Name, A.Region) -> [(Name.Name, A.Region)] -> Report.Report -unboundTypeVars source declRegion tipe typeName allVars (unboundVar, varRegion) unboundVars = - let - backQuote name = - "`" <> D.fromName name <> "`" - - (title, subRegion, overview) = - case map fst unboundVars of - [] -> - ( "UNBOUND TYPE VARIABLE" - , Just varRegion - , ["The",backQuote typeName] - ++ tipe - ++ ["uses","an","unbound","type","variable",D.dullyellow (backQuote unboundVar),"in","its","definition:"] - ) - - vars -> - ( "UNBOUND TYPE VARIABLES" - , Nothing - , ["Type","variables"] - ++ D.commaSep "and" D.dullyellow (D.fromName unboundVar : map D.fromName vars) - ++ ["are","unbound","in","the",backQuote typeName] ++ tipe ++ ["definition:"] - ) - in - Report.Report title declRegion [] $ - Code.toSnippet source declRegion subRegion - ( - D.fillSep overview - , - D.stack - [ D.reflow $ - "You probably need to change the declaration to something like this:" - , D.indent 4 $ D.hsep $ - tipe - ++ [D.fromName typeName] - ++ map D.fromName allVars - ++ map (D.green . D.fromName) (unboundVar : map fst unboundVars) - ++ ["=", "..."] - , D.reflow $ - "Why? Well, imagine one `" ++ Name.toChars typeName ++ "` where `" ++ Name.toChars unboundVar ++ - "` is an Int and another where it is a Bool. When we explicitly list the type\ - \ variables, the type checker can see that they are actually different types." - ] - ) - - - --- NAME CLASH - - -nameClash :: Code.Source -> A.Region -> A.Region -> String -> Report.Report -nameClash source r1 r2 messageThatEndsWithPunctuation = - Report.Report "NAME CLASH" r2 [] $ - Code.toPair source r1 r2 - ( - D.reflow messageThatEndsWithPunctuation - , - "How can I know which one you want? Rename one of them!" - ) - ( - D.reflow (messageThatEndsWithPunctuation <> " One here:") - , - "And another one here:" - , - "How can I know which one you want? Rename one of them!" - ) - - - --- AMBIGUOUS NAME - - -ambiguousName :: Code.Source -> A.Region -> Maybe Name.Name -> Name.Name -> [ModuleName.Canonical] -> String -> Report.Report -ambiguousName source region maybePrefix name possibleHomes thing = - Report.Report "AMBIGUOUS NAME" region [] $ - Code.toSnippet source region Nothing $ - case maybePrefix of - Nothing -> - let - homeToYellowDoc (ModuleName.Canonical _ home) = - D.dullyellow (D.fromName home <> "." <> D.fromName name) - in - ( - D.reflow $ "This usage of `" ++ Name.toChars name ++ "` is ambiguous:" - , - D.stack - [ D.reflow $ - "This name is exposed by " ++ show (length possibleHomes) ++ " of your imports, so I am not\ - \ sure which one to use:" - , D.indent 4 $ D.vcat $ map homeToYellowDoc possibleHomes - , D.reflow $ - "I recommend using qualified names for imported values. I also recommend having\ - \ at most one `exposing (..)` per file to make name clashes like this less common\ - \ in the long run." - , D.link "Note" "Check out" "imports" "for more info on the import syntax." - ] - ) - - Just prefix -> - let - homeToYellowDoc (ModuleName.Canonical _ home) = - if prefix == home then - D.cyan "import" <+> D.fromName home - else - D.cyan "import" <+> D.fromName home <+> D.cyan "as" <+> D.fromName prefix - - eitherOrAny = - if length possibleHomes == 2 then "either" else "any" - in - ( - D.reflow $ "This usage of `" ++ toQualString prefix name ++ "` is ambiguous." - , - D.stack - [ D.reflow $ - "It could refer to a " ++ thing ++ " from " - ++ eitherOrAny ++ " of these imports:" - , D.indent 4 $ D.vcat $ map homeToYellowDoc possibleHomes - , D.reflowLink "Read" "imports" "to learn how to clarify which one you want." - ] - ) - - - --- NOT FOUND - - -notFound :: Code.Source -> A.Region -> Maybe Name.Name -> Name.Name -> String -> PossibleNames -> Report.Report -notFound source region maybePrefix name thing (PossibleNames locals quals) = - let - givenName = - maybe Name.toChars toQualString maybePrefix name - - possibleNames = - let - addQuals prefix localSet allNames = - Set.foldr (\x xs -> toQualString prefix x : xs) allNames localSet - in - Map.foldrWithKey addQuals (map Name.toChars (Set.toList locals)) quals - - nearbyNames = - take 4 (Suggest.sort givenName id possibleNames) - - toDetails noSuggestionDetails yesSuggestionDetails = - case nearbyNames of - [] -> - D.stack - [ D.reflow noSuggestionDetails - , D.link "Hint" "Read" "imports" "to see how `import` declarations work in Elm." - ] - - suggestions -> - D.stack - [ D.reflow yesSuggestionDetails - , D.indent 4 $ D.vcat $ map D.dullyellow $ map D.fromChars suggestions - , D.link "Hint" "Read" "imports" "to see how `import` declarations work in Elm." - ] - - in - Report.Report "NAMING ERROR" region nearbyNames $ - Code.toSnippet source region Nothing - ( - D.reflow $ - "I cannot find a `" ++ givenName ++ "` " ++ thing ++ ":" - , - case maybePrefix of - Nothing -> - toDetails - "Is there an `import` or `exposing` missing up top?" - "These names seem close though:" - - Just prefix -> - case Map.lookup prefix quals of - Nothing -> - toDetails - ("I cannot find a `" ++ Name.toChars prefix ++ "` module. Is there an `import` for it?") - ("I cannot find a `" ++ Name.toChars prefix ++ "` import. These names seem close though:") - - Just _ -> - toDetails - ("The `" ++ Name.toChars prefix ++ "` module does not expose a `" ++ Name.toChars name ++ "` " ++ thing ++ ".") - ("The `" ++ Name.toChars prefix ++ "` module does not expose a `" ++ Name.toChars name ++ "` " ++ thing ++ ". These names seem close though:") - ) - - -toQualString :: Name.Name -> Name.Name -> String -toQualString prefix name = - Name.toChars prefix ++ "." ++ Name.toChars name - - - -{-- VAR ERROR - - -varErrorToReport :: VarError -> Report.Report -varErrorToReport (VarError kind name problem suggestions) = - let - learnMore orMaybe = - D.reflow $ - orMaybe <> " `import` works different than you expect? Learn all about it here: " - <> D.hintLink "imports" - - namingError overview maybeStarter specializedSuggestions = - Report.reportDoc "NAMING ERROR" Nothing overview $ - case D.maybeYouWant' maybeStarter specializedSuggestions of - Nothing -> - learnMore "Maybe" - Just doc -> - D.stack [ doc, learnMore "Or maybe" ] - - specialNamingError specialHint = - Report.reportDoc "NAMING ERROR" Nothing (cannotFind kind name) (D.hsep specialHint) - in - case problem of - Ambiguous -> - namingError (ambiguous kind name) Nothing suggestions - - UnknownQualifier qualifier localName -> - namingError - (cannotFind kind name) - (Just $ text $ "No module called `" <> qualifier <> "` has been imported.") - (map (\modul -> modul <> "." <> localName) suggestions) - - QualifiedUnknown qualifier localName -> - namingError - (cannotFind kind name) - (Just $ text $ "`" <> qualifier <> "` does not expose `" <> localName <> "`.") - (map (\v -> qualifier <> "." <> v) suggestions) - - ExposedUnknown -> - case name of - "!=" -> specialNamingError (notEqualsHint name) - "!==" -> specialNamingError (notEqualsHint name) - "===" -> specialNamingError equalsHint - "%" -> specialNamingError modHint - _ -> namingError (cannotFind kind name) Nothing suggestions - - -cannotFind :: VarKind -> Text -> [Doc] -cannotFind kind rawName = - let ( a, thing, name ) = toKindInfo kind rawName in - [ "Cannot", "find", a, thing, "named", D.dullyellow name <> ":" ] - - -ambiguous :: VarKind -> Text -> [Doc] -ambiguous kind rawName = - let ( _a, thing, name ) = toKindInfo kind rawName in - [ "This", "usage", "of", "the", D.dullyellow name, thing, "is", "ambiguous." ] - - -notEqualsHint :: Text -> [Doc] -notEqualsHint op = - [ "Looking", "for", "the", "“not", "equal”", "operator?", "The", "traditional" - , D.dullyellow $ text $ "(" <> op <> ")" - , "is", "replaced", "by", D.green "(/=)", "in", "Elm.", "It", "is", "meant" - , "to", "look", "like", "the", "“not", "equal”", "sign", "from", "math!", "(≠)" - ] - - -equalsHint :: [Doc] -equalsHint = - [ "A", "special", D.dullyellow "(===)", "operator", "is", "not", "needed" - , "in", "Elm.", "We", "use", D.green "(==)", "for", "everything!" - ] - - -modHint :: [Doc] -modHint = - [ "Rather", "than", "a", D.dullyellow "(%)", "operator," - , "Elm", "has", "a", D.green "modBy", "function." - , "Learn", "more", "here:" - , "" - ] - - --} - - --- ARG MISMATCH - - -_argMismatchReport :: Code.Source -> A.Region -> String -> Name.Name -> Int -> Int -> Report.Report -_argMismatchReport source region kind name expected actual = - let - numArgs = - "too " - <> (if actual < expected then "few" else "many") - <> " arguments" - in - Report.Report (map Char.toUpper numArgs) region [] $ - Code.toSnippet source region Nothing - ( - D.reflow $ - kind <> " " <> Name.toChars name <> " has " <> numArgs <> "." - , - D.reflow $ - "Expecting " <> show expected <> ", but got " <> show actual <> "." - ) - - - --- BAD ALIAS RECURSION - - -aliasRecursionReport :: Code.Source -> A.Region -> Name.Name -> [Name.Name] -> Src.Type -> [Name.Name] -> Report.Report -aliasRecursionReport source region name args tipe others = - case others of - [] -> - Report.Report "ALIAS PROBLEM" region [] $ - Code.toSnippet source region Nothing - ( - "This type alias is recursive, forming an infinite type!" - , - D.stack - [ D.reflow $ - "When I expand a recursive type alias, it just keeps getting bigger and bigger.\ - \ So dealiasing results in an infinitely large type! Try this instead:" - , D.indent 4 $ - aliasToUnionDoc name args tipe - , D.link "Hint" - "This is kind of a subtle distinction. I suggested the naive fix, but I recommend reading" - "recursive-alias" - "for ideas on how to do better." - ] - ) - - _ -> - Report.Report "ALIAS PROBLEM" region [] $ - Code.toSnippet source region Nothing - ( - "This type alias is part of a mutually recursive set of type aliases." - , - D.stack - [ "It is part of this cycle of type aliases:" - , D.cycle 4 name others - , D.reflow $ - "You need to convert at least one of these type aliases into a `type`." - , D.link "Note" "Read" "recursive-alias" - "to learn why this `type` vs `type alias` distinction matters. It is subtle but important!" - ] - ) - - -aliasToUnionDoc :: Name.Name -> [Name.Name] -> Src.Type -> Doc -aliasToUnionDoc name args tipe = - D.vcat - [ D.dullyellow $ - "type" <+> D.fromName name <+> (foldr (<+>) "=" (map D.fromName args)) - , D.green $ - D.indent 4 (D.fromName name) - , D.dullyellow $ - D.indent 8 (RT.srcToDoc RT.App tipe) - ] diff --git a/compiler/src/Reporting/Error/Docs.hs b/compiler/src/Reporting/Error/Docs.hs deleted file mode 100644 index 310b326014..0000000000 --- a/compiler/src/Reporting/Error/Docs.hs +++ /dev/null @@ -1,250 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE OverloadedStrings #-} -module Reporting.Error.Docs - ( Error(..) - , SyntaxProblem(..) - , NameProblem(..) - , DefProblem(..) - , toReports - ) - where - - -import qualified Data.Name as Name -import qualified Data.NonEmptyList as NE - -import Parse.Primitives (Row, Col) -import Parse.Symbol (BadOperator(..)) -import qualified Reporting.Annotation as A -import Reporting.Doc ((<>)) -import qualified Reporting.Doc as D -import qualified Reporting.Render.Code as Code -import qualified Reporting.Error.Syntax as E -import qualified Reporting.Report as Report - - - -data Error - = NoDocs A.Region - | ImplicitExposing A.Region - | SyntaxProblem SyntaxProblem - | NameProblems (NE.List NameProblem) - | DefProblems (NE.List DefProblem) - - -data SyntaxProblem - = Op Row Col - | OpBad BadOperator Row Col - | Name Row Col - | Space E.Space Row Col - | Comma Row Col - | BadEnd Row Col - - -data NameProblem - = NameDuplicate Name.Name A.Region A.Region - | NameOnlyInDocs Name.Name A.Region - | NameOnlyInExports Name.Name A.Region - - -data DefProblem - = NoComment Name.Name A.Region - | NoAnnotation Name.Name A.Region - - - --- TO REPORTS - - -toReports :: Code.Source -> Error -> NE.List Report.Report -toReports source err = - case err of - NoDocs region -> - NE.singleton $ - Report.Report "NO DOCS" region [] $ - Code.toSnippet source region Nothing - ( - D.reflow $ - "You must have a documentation comment between the module\ - \ declaration and the imports." - , - D.reflow - "Learn more at " - ) - - ImplicitExposing region -> - NE.singleton $ - Report.Report "IMPLICIT EXPOSING" region [] $ - Code.toSnippet source region Nothing - ( - D.reflow $ - "I need you to be explicit about what this module exposes:" - , - D.reflow $ - "A great API usually hides some implementation details, so it is rare that\ - \ everything in the file should be exposed. And requiring package authors\ - \ to be explicit about this is a way of adding another quality check before\ - \ code gets published. So as you write out the public API, ask yourself if\ - \ it will be easy to understand as people read the documentation!" - ) - - SyntaxProblem problem -> - NE.singleton $ - toSyntaxProblemReport source problem - - NameProblems problems -> - fmap (toNameProblemReport source) problems - - DefProblems problems -> - fmap (toDefProblemReport source) problems - - - --- SYNTAX PROBLEM - - -toSyntaxProblemReport :: Code.Source -> SyntaxProblem -> Report.Report -toSyntaxProblemReport source problem = - let - toSyntaxReport row col details = - let - region = toRegion row col - in - Report.Report "PROBLEM IN DOCS" region [] $ - Code.toSnippet source region Nothing - ( D.reflow "I was partway through parsing your module documentation, but I got stuck here:" - , D.stack $ - [ D.reflow details - , D.toSimpleHint $ - "Read through for\ - \ tips on how to write module documentation!" - ] - ) - in - case problem of - Op row col -> - toSyntaxReport row col $ - "I am trying to parse an operator like (+) or (*) but something is going wrong." - - OpBad _ row col -> - toSyntaxReport row col $ - "I am trying to parse an operator like (+) or (*) but it looks like you are using\ - \ a reserved symbol in this case." - - Name row col -> - toSyntaxReport row col $ - "I was expecting to see the name of another exposed value from this module." - - Space space row col -> - E.toSpaceReport source space row col - - Comma row col -> - toSyntaxReport row col $ - "I was expecting to see a comma next." - - BadEnd row col -> - toSyntaxReport row col $ - "I am not really sure what I am getting stuck on though." - - -toRegion :: Row -> Col -> A.Region -toRegion row col = - let - pos = A.Position row col - in - A.Region pos pos - - - --- NAME PROBLEM - - -toNameProblemReport :: Code.Source -> NameProblem -> Report.Report -toNameProblemReport source problem = - case problem of - NameDuplicate name r1 r2 -> - Report.Report "DUPLICATE DOCS" r2 [] $ - Code.toPair source r1 r2 - ( - D.reflow $ - "There can only be one `" <> Name.toChars name - <> "` in your module documentation, but it is listed twice:" - , - "Remove one of them!" - ) - ( - D.reflow $ - "There can only be one `" <> Name.toChars name - <> "` in your module documentation, but I see two. One here:" - , - "And another one over here:" - , - "Remove one of them!" - ) - - NameOnlyInDocs name region -> - Report.Report "DOCS MISTAKE" region [] $ - Code.toSnippet source region Nothing - ( - D.reflow $ - "I do not see `" <> Name.toChars name - <> "` in the `exposing` list, but it is in your module documentation:" - , - D.reflow $ - "Does it need to be added to the `exposing` list as well? Or maybe you removed `" - <> Name.toChars name <> "` and forgot to delete it here?" - ) - - NameOnlyInExports name region -> - Report.Report "DOCS MISTAKE" region [] $ - Code.toSnippet source region Nothing - ( - D.reflow $ - "I do not see `" <> Name.toChars name - <> "` in your module documentation, but it is in your `exposing` list:" - , - D.stack - [ D.reflow $ - "Add a line like `@docs " <> Name.toChars name - <> "` to your module documentation!" - , D.link "Note" "See" "docs" "for more guidance on writing high quality docs." - ] - ) - - - --- DEF PROBLEM - - -toDefProblemReport :: Code.Source -> DefProblem -> Report.Report -toDefProblemReport source problem = - case problem of - NoComment name region -> - Report.Report "NO DOCS" region [] $ - Code.toSnippet source region Nothing - ( - D.reflow $ - "The `" <> Name.toChars name <> "` definition does not have a documentation comment." - , - D.stack - [ D.reflow $ - "Add documentation with nice examples of how to use it!" - , D.link "Note" "Read" "docs" "for more advice on writing great docs. There are a couple important tricks!" - ] - ) - - NoAnnotation name region -> - Report.Report "NO TYPE ANNOTATION" region [] $ - Code.toSnippet source region Nothing - ( - D.reflow $ - "The `" <> Name.toChars name <> "` definition does not have a type annotation." - , - D.stack - [ D.reflow $ - "I use the type variable names from your annotations when generating docs. So if\ - \ you say `Html msg` in your type annotation, I can use `msg` in the docs and make\ - \ them a bit clearer. So add an annotation and try to use nice type variables!" - , D.link "Note" "Read" "docs" "for more advice on writing great docs. There are a couple important tricks!" - ] - ) diff --git a/compiler/src/Reporting/Error/Import.hs b/compiler/src/Reporting/Error/Import.hs deleted file mode 100644 index 91a9a5b0b1..0000000000 --- a/compiler/src/Reporting/Error/Import.hs +++ /dev/null @@ -1,162 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module Reporting.Error.Import - ( Error(..) - , Problem(..) - , toReport - ) - where - - -import qualified Data.Map as Map -import qualified Data.Set as Set - -import qualified Elm.ModuleName as ModuleName -import qualified Elm.Package as Pkg -import qualified Reporting.Doc as D -import qualified Reporting.Render.Code as Code -import qualified Reporting.Report as Report -import qualified Reporting.Suggest as Suggest -import qualified Reporting.Annotation as A - - - --- ERROR - - -data Error = - Error - { _region :: A.Region - , _import :: ModuleName.Raw - , _unimported :: Set.Set ModuleName.Raw - , _problem :: Problem - } - - -data Problem - = NotFound - | Ambiguous FilePath [FilePath] Pkg.Name [Pkg.Name] - | AmbiguousLocal FilePath FilePath [FilePath] - | AmbiguousForeign Pkg.Name Pkg.Name [Pkg.Name] - - - --- TO REPORT - - -toReport :: Code.Source -> Error -> Report.Report -toReport source (Error region name unimportedModules problem) = - case problem of - NotFound -> - Report.Report "MODULE NOT FOUND" region [] $ - Code.toSnippet source region Nothing - ( - D.reflow $ - "You are trying to import a `" ++ ModuleName.toChars name ++ "` module:" - , - D.stack - [ - D.reflow $ - "I checked the \"dependencies\" and \"source-directories\" listed in your elm.json,\ - \ but I cannot find it! Maybe it is a typo for one of these names?" - , - D.dullyellow $ D.indent 4 $ D.vcat $ - map D.fromName (toSuggestions name unimportedModules) - , - case Map.lookup name Pkg.suggestions of - Nothing -> - D.toSimpleHint $ - "If it is not a typo, check the \"dependencies\" and \"source-directories\"\ - \ of your elm.json to make sure all the packages you need are listed there!" - - Just dependency -> - D.toFancyHint - ["Maybe","you","want","the" - ,"`" <> D.fromName name <> "`" - ,"module","defined","in","the" - ,D.fromChars (Pkg.toChars dependency) - ,"package?","Running" - ,D.green (D.fromChars ("elm install " ++ Pkg.toChars dependency)) - ,"should","make","it","available!" - ] - ] - ) - - Ambiguous path _ pkg _ -> - Report.Report "AMBIGUOUS IMPORT" region [] $ - Code.toSnippet source region Nothing - ( - D.reflow $ - "You are trying to import a `" ++ ModuleName.toChars name ++ "` module:" - , - D.stack - [ - D.fillSep $ - ["But","I","found","multiple","modules","with","that","name.","One","in","the" - ,D.dullyellow (D.fromChars (Pkg.toChars pkg)) - ,"package,","and","another","defined","locally","in","the" - ,D.dullyellow (D.fromChars path) - ,"file.","I","do","not","have","a","way","to","choose","between","them." - ] - , - D.reflow $ - "Try changing the name of the locally defined module to clear up the ambiguity?" - ] - ) - - AmbiguousLocal path1 path2 paths -> - Report.Report "AMBIGUOUS IMPORT" region [] $ - Code.toSnippet source region Nothing - ( - D.reflow $ - "You are trying to import a `" ++ ModuleName.toChars name ++ "` module:" - , - D.stack - [ - D.reflow $ - "But I found multiple files in your \"source-directories\" with that name:" - , - D.dullyellow $ D.indent 4 $ D.vcat $ - map D.fromChars (path1:path2:paths) - , - D.reflow $ - "Change the module names to be distinct!" - ] - ) - - AmbiguousForeign pkg1 pkg2 pkgs -> - Report.Report "AMBIGUOUS IMPORT" region [] $ - Code.toSnippet source region Nothing - ( - D.reflow $ - "You are trying to import a `" ++ ModuleName.toChars name ++ "` module:" - , - D.stack - [ - D.reflow $ - "But multiple packages in your \"dependencies\" that expose a module that name:" - , - D.dullyellow $ D.indent 4 $ D.vcat $ - map (D.fromChars . Pkg.toChars) (pkg1:pkg2:pkgs) - , - D.reflow $ - "There is no way to disambiguate in cases like this right now. Of the known name\ - \ clashes, they are usually for packages with similar purposes, so the current\ - \ recommendation is to pick just one of them." - , D.toSimpleNote $ - "It seems possible to resolve this with new syntax in imports, but that is\ - \ more complicated than it sounds. Right now, our module names are tied to GitHub\ - \ repos, but we may want to get rid of that dependency for a variety of reasons.\ - \ That would in turn have implications for our package infrastructure, hosting\ - \ costs, and possibly on how package names are specified. The particular syntax\ - \ chosen seems like it would interact with all these factors in ways that are\ - \ difficult to predict, potentially leading to harder problems later on. So more\ - \ design work and planning is needed on these topics." - ] - ) - - - -toSuggestions :: ModuleName.Raw -> Set.Set ModuleName.Raw -> [ModuleName.Raw] -toSuggestions name unimportedModules = - take 4 $ - Suggest.sort (ModuleName.toChars name) ModuleName.toChars (Set.toList unimportedModules) diff --git a/compiler/src/Reporting/Error/Json.hs b/compiler/src/Reporting/Error/Json.hs deleted file mode 100644 index 9d8bdf9387..0000000000 --- a/compiler/src/Reporting/Error/Json.hs +++ /dev/null @@ -1,344 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE OverloadedStrings #-} -module Reporting.Error.Json - ( toReport - , FailureToReport(..) - , Context(..) - , Reason(..) - ) - where - - -import qualified Data.ByteString as BS -import qualified Data.ByteString.UTF8 as BS_UTF8 -import qualified Data.NonEmptyList as NE - -import Json.Decode (Error(..), Problem(..), DecodeExpectation(..), ParseError(..), StringProblem(..)) -import qualified Reporting.Annotation as A -import qualified Reporting.Doc as D -import qualified Reporting.Exit.Help as Help -import qualified Reporting.Render.Code as Code - - - --- TO REPORT - - -toReport :: FilePath -> FailureToReport x -> Error x -> Reason -> Help.Report -toReport path ftr err reason = - case err of - DecodeProblem bytes problem -> - problemToReport path ftr (Code.toSource bytes) CRoot problem reason - - ParseProblem bytes parseError -> - parseErrorToReport path (Code.toSource bytes) parseError reason - - -newtype Reason = - ExplicitReason String - - -because :: Reason -> String -> String -because (ExplicitReason iNeedThings) problem = - iNeedThings ++ " " ++ problem - - - --- PARSE ERROR TO REPORT - - -parseErrorToReport :: FilePath -> Code.Source -> ParseError -> Reason -> Help.Report -parseErrorToReport path source parseError reason = - let - toSnippet title row col (problem, details) = - let - pos = A.Position row col - surroundings = A.Region (A.Position (max 1 (row - 2)) 1) pos - region = A.Region pos pos - in - Help.jsonReport title (Just path) $ - Code.toSnippet source surroundings (Just region) - ( D.reflow (because reason problem) - , details - ) - in - case parseError of - Start row col -> - toSnippet "EXPECTING A VALUE" row col - ( - "I was expecting to see a JSON value next:" - , - D.stack - [ D.fillSep - ["Try","something","like",D.dullyellow "\"this\"","or" - ,D.dullyellow "42","to","move","on","to","better","hints!" - ] - , D.toSimpleNote $ - "The JSON specification does not allow trailing commas, so you can sometimes\ - \ get this error in arrays that have an extra comma at the end. In that case,\ - \ remove that last comma or add another array entry after it!" - ] - ) - - ObjectField row col -> - toSnippet "EXTRA COMMA" row col - ( - "I was partway through parsing a JSON object when I got stuck here:" - , - D.stack - [ D.fillSep - ["I","saw","a","comma","right","before","I","got","stuck","here," - ,"so","I","was","expecting","to","see","a","field","name","like" - ,D.dullyellow "\"type\"","or",D.dullyellow "\"dependencies\"","next." - ] - , D.reflow $ - "This error is commonly caused by trailing commas in JSON objects. Those are\ - \ actually disallowed by so check the previous line for a\ - \ trailing comma that may need to be deleted." - , objectNote - ] - ) - - ObjectColon row col -> - toSnippet "EXPECTING COLON" row col - ( - "I was partway through parsing a JSON object when I got stuck here:" - , - D.stack - [ D.reflow $ "I was expecting to see a colon next." - , objectNote - ] - ) - - ObjectEnd row col -> - toSnippet "UNFINISHED OBJECT" row col - ( - "I was partway through parsing a JSON object when I got stuck here:" - , - D.stack - [ D.reflow $ - "I was expecting to see a comma or a closing curly brace next." - , D.reflow $ - "Is a comma missing on the previous line? Is an array missing a closing square\ - \ bracket? It is often something tricky like that!" - , objectNote - ] - ) - - ArrayEnd row col -> - toSnippet "UNFINISHED ARRAY" row col - ( - "I was partway through parsing a JSON array when I got stuck here:" - , - D.stack - [ D.reflow $ "I was expecting to see a comma or a closing square bracket next." - , D.reflow $ - "Is a comma missing on the previous line? It is often something like that!" - ] - ) - - StringProblem stringProblem row col -> - case stringProblem of - BadStringEnd -> - toSnippet "ENDLESS STRING" row col - ( - "I got to the end of the line without seeing the closing double quote:" - , - D.fillSep $ - ["Strings","look","like",D.green "\"this\"","with","double" - ,"quotes","on","each","end.","Is","the","closing","double" - ,"quote","missing","in","your","code?" - ] - ) - - BadStringControlChar -> - toSnippet "UNEXPECTED CONTROL CHARACTER" row col - ( - "I ran into a control character unexpectedly:" - , - D.reflow $ - "These are characters that represent tabs, backspaces, newlines, and\ - \ a bunch of other invisible characters. They all come before 20 in the\ - \ ASCII range, and they are disallowed by the JSON specificaiton. Maybe\ - \ a copy/paste added one of these invisible characters to your JSON?" - ) - - BadStringEscapeChar -> - toSnippet "UNKNOWN ESCAPE" row col - ( - "Backslashes always start escaped characters, but I do not recognize this one:" - , - D.stack - [ D.reflow $ - "Valid escape characters include:" - , D.dullyellow $ D.indent 4 $ D.vcat $ - ["\\\"","\\\\","\\/","\\b","\\f","\\n","\\r","\\t","\\u003D"] - , D.reflow $ - "Do you want one of those instead? Maybe you need \\\\ to escape a backslash?" - ] - ) - - BadStringEscapeHex -> - toSnippet "BAD HEX ESCAPE" row col - ( - "This is not a valid hex escape:" - , - D.fillSep $ - ["Valid","hex","escapes","in","JSON","are","between" - ,D.green "\\u0000","and",D.green "\\uFFFF" - ,"and","always","have","exactly","four","digits." - ] - ) - - NoLeadingZeros row col -> - toSnippet "BAD NUMBER" row col - ( - "Numbers cannot start with zeros like this:" - , - D.reflow $ "Try deleting the leading zeros?" - ) - - NoFloats row col -> - toSnippet "UNEXPECTED NUMBER" row col - ( - "I got stuck while trying to parse this number:" - , - D.reflow $ - "I do not accept floating point numbers like 3.1415 right now. That kind\ - \ of JSON value is not needed for any of the uses that Elm has for now." - ) - - BadEnd row col -> - toSnippet "JSON PROBLEM" row col - ( - "I was partway through parsing some JSON when I got stuck here:" - , - D.reflow $ - "I am not really sure what is wrong. This sometimes means there is extra\ - \ stuff after a valid JSON value?" - ) - - -objectNote :: D.Doc -objectNote = - D.stack - [ D.toSimpleNote $ "Here is an example of a valid JSON object for reference:" - , D.vcat - [ D.indent 4 $ "{" - , D.indent 6 $ D.dullyellow "\"name\"" <> ": " <> D.dullyellow "\"Tom\"" <> "," - , D.indent 6 $ D.dullyellow "\"age\"" <> ": " <> D.dullyellow "42" - , D.indent 4 $ "}" - ] - , D.reflow $ - "Notice that (1) the field names are in double quotes and (2) there is no\ - \ trailing comma after the last entry. Both are strict requirements in JSON!" - ] - - - --- PROBLEM TO REPORT - - -data Context - = CRoot - | CField BS.ByteString Context - | CIndex Int Context - - -problemToReport :: FilePath -> FailureToReport x -> Code.Source -> Context -> Problem x -> Reason -> Help.Report -problemToReport path ftr source context problem reason = - case problem of - Field field prob -> - problemToReport path ftr source (CField field context) prob reason - - Index index prob -> - problemToReport path ftr source (CIndex index context) prob reason - - OneOf p ps -> - -- NOTE: only displays the deepest problem. This works well for the kind - -- of JSON used by Elm, but probably would not work well in general. - let - (NE.List prob _) = NE.sortBy (negate . getMaxDepth) (NE.List p ps) - in - problemToReport path ftr source context prob reason - - Failure region x -> - _failureToReport ftr path source context region x - - Expecting region expectation -> - expectationToReport path source context region expectation reason - - -getMaxDepth :: Problem x -> Int -getMaxDepth problem = - case problem of - Field _ prob -> 1 + getMaxDepth prob - Index _ prob -> 1 + getMaxDepth prob - OneOf p ps -> maximum (getMaxDepth p : map getMaxDepth ps) - Failure _ _ -> 0 - Expecting _ _ -> 0 - - -newtype FailureToReport x = - FailureToReport { _failureToReport :: FilePath -> Code.Source -> Context -> A.Region -> x -> Help.Report } - - -expectationToReport :: FilePath -> Code.Source -> Context -> A.Region -> DecodeExpectation -> Reason -> Help.Report -expectationToReport path source context (A.Region start end) expectation reason = - let - (A.Position sr _) = start - (A.Position er _) = end - - region = - if sr == er then region else A.Region start start - - introduction = - case context of - CRoot -> - "I ran into some trouble here:" - - CField field _ -> - "I ran into trouble with the value of the \"" ++ BS_UTF8.toString field ++ "\" field:" - - CIndex index (CField field _) -> - "When looking at the \"" ++ BS_UTF8.toString field ++ "\" field, I ran into trouble with the " - ++ D.intToOrdinal index ++ " entry:" - - CIndex index _ -> - "I ran into trouble with the " ++ D.intToOrdinal index ++ " index of this array:" - - toSnippet title aThing = - Help.jsonReport title (Just path) $ - Code.toSnippet source region Nothing - ( D.reflow (because reason introduction) - , D.fillSep $ ["I","was","expecting","to","run","into"] ++ aThing - ) - in - case expectation of - TObject -> - toSnippet "EXPECTING OBJECT" ["an", D.green "OBJECT" <> "."] - - TArray -> - toSnippet "EXPECTING ARRAY" ["an", D.green "ARRAY" <> "."] - - TString -> - toSnippet "EXPECTING STRING" ["a", D.green "STRING" <> "."] - - TBool -> - toSnippet "EXPECTING BOOL" ["a", D.green "BOOLEAN" <> "."] - - TInt -> - toSnippet "EXPECTING INT" ["an", D.green "INT" <> "."] - - TObjectWith field -> - toSnippet "MISSING FIELD" - ["an",D.green "OBJECT","with","a" - ,D.green ("\"" <> D.fromChars (BS_UTF8.toString field) <> "\"") - ,"field." - ] - - TArrayPair len -> - toSnippet "EXPECTING PAIR" - ["an",D.green "ARRAY","with",D.green "TWO","entries." - ,"This","array","has",D.fromInt len, if len == 1 then "element." else "elements." - ] diff --git a/compiler/src/Reporting/Error/Main.hs b/compiler/src/Reporting/Error/Main.hs deleted file mode 100644 index 570118ab85..0000000000 --- a/compiler/src/Reporting/Error/Main.hs +++ /dev/null @@ -1,124 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE OverloadedStrings #-} -module Reporting.Error.Main - ( Error(..) - , toReport - ) - where - - -import qualified Data.Name as Name - -import qualified AST.Canonical as Can -import qualified Reporting.Annotation as A -import qualified Reporting.Doc as D -import qualified Reporting.Error.Canonicalize as E -import qualified Reporting.Render.Code as Code -import qualified Reporting.Render.Type as RT -import qualified Reporting.Render.Type.Localizer as L -import qualified Reporting.Report as Report - - - --- ERROR - - -data Error - = BadType A.Region Can.Type - | BadCycle A.Region Name.Name [Name.Name] - | BadFlags A.Region Can.Type E.InvalidPayload - - - --- TO REPORT - - -toReport :: L.Localizer -> Code.Source -> Error -> Report.Report -toReport localizer source err = - case err of - BadType region tipe -> - Report.Report "BAD MAIN TYPE" region [] $ - Code.toSnippet source region Nothing - ( - "I cannot handle this type of `main` value:" - , - D.stack - [ "The type of `main` value I am seeing is:" - , D.indent 4 $ D.dullyellow $ RT.canToDoc localizer RT.None tipe - , D.reflow $ - "I only know how to handle Html, Svg, and Programs\ - \ though. Modify `main` to be one of those types of values!" - ] - ) - - BadCycle region name names -> - Report.Report "BAD MAIN" region [] $ - Code.toSnippet source region Nothing - ( - "A `main` definition cannot be defined in terms of itself." - , - D.stack - [ D.reflow $ - "It should be a boring value with no recursion. But\ - \ instead it is involved in this cycle of definitions:" - , D.cycle 4 name names - ] - ) - - BadFlags region _badType invalidPayload -> - let - formatDetails (aBadKindOfThing, butThatIsNoGood) = - Report.Report "BAD FLAGS" region [] $ - Code.toSnippet source region Nothing - ( - D.reflow $ - "Your `main` program wants " ++ aBadKindOfThing ++ " from JavaScript." - , - butThatIsNoGood - ) - in - formatDetails $ - case invalidPayload of - E.ExtendedRecord -> - ( - "an extended record" - , - D.reflow $ - "But the exact shape of the record must be known at compile time. No type variables!" - ) - - E.Function -> - ( - "a function" - , - D.reflow $ - "But if I allowed functions from JS, it would be possible to sneak\ - \ side-effects and runtime exceptions into Elm!" - ) - - E.TypeVariable name -> - ( - "an unspecified type" - , - D.reflow $ - "But type variables like `" ++ Name.toChars name ++ "` cannot be given as flags.\ - \ I need to know exactly what type of data I am getting, so I can guarantee that\ - \ unexpected data cannot sneak in and crash the Elm program." - ) - - E.UnsupportedType name -> - ( - "a `" ++ Name.toChars name ++ "` value" - , - D.stack - [ D.reflow $ "I cannot handle that. The types that CAN be in flags include:" - , D.indent 4 $ - D.reflow $ - "Ints, Floats, Bools, Strings, Maybes, Lists, Arrays,\ - \ tuples, records, and JSON values." - , D.reflow $ - "Since JSON values can flow through, you can use JSON encoders and decoders\ - \ to allow other types through as well. More advanced users often just do\ - \ everything with encoders and decoders for more control and better errors." - ] - ) diff --git a/compiler/src/Reporting/Error/Pattern.hs b/compiler/src/Reporting/Error/Pattern.hs deleted file mode 100644 index 0191a0f20a..0000000000 --- a/compiler/src/Reporting/Error/Pattern.hs +++ /dev/null @@ -1,195 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE OverloadedStrings #-} -module Reporting.Error.Pattern - ( P.Error(..) - , toReport - ) - where - -import qualified Data.List as List - -import qualified Elm.String as ES -import qualified Nitpick.PatternMatches as P -import Reporting.Doc ((<>)) -import qualified Reporting.Doc as D -import qualified Reporting.Report as Report -import qualified Reporting.Render.Code as Code - - - --- TO REPORT - - -toReport :: Code.Source -> P.Error -> Report.Report -toReport source err = - case err of - P.Redundant caseRegion patternRegion index -> - Report.Report "REDUNDANT PATTERN" patternRegion [] $ - Code.toSnippet source caseRegion (Just patternRegion) - ( - D.reflow $ - "The " <> D.intToOrdinal index <> " pattern is redundant:" - , - D.reflow $ - "Any value with this shape will be handled by a previous\ - \ pattern, so it should be removed." - ) - - P.Incomplete region context unhandled -> - case context of - P.BadArg -> - Report.Report "UNSAFE PATTERN" region [] $ - Code.toSnippet source region Nothing - ( - "This pattern does not cover all possiblities:" - , - D.stack - [ "Other possibilities include:" - , unhandledPatternsToDocBlock unhandled - , D.reflow $ - "I would have to crash if I saw one of those! So rather than\ - \ pattern matching in function arguments, put a `case` in\ - \ the function body to account for all possibilities." - ] - ) - - P.BadDestruct -> - Report.Report "UNSAFE PATTERN" region [] $ - Code.toSnippet source region Nothing - ( - "This pattern does not cover all possible values:" - , - D.stack - [ "Other possibilities include:" - , unhandledPatternsToDocBlock unhandled - , D.reflow $ - "I would have to crash if I saw one of those! You can use\ - \ `let` to deconstruct values only if there is ONE possiblity.\ - \ Switch to a `case` expression to account for all possibilities." - , D.toSimpleHint $ - "Are you calling a function that definitely returns values\ - \ with a very specific shape? Try making the return type of\ - \ that function more specific!" - ] - ) - - P.BadCase -> - Report.Report "MISSING PATTERNS" region [] $ - Code.toSnippet source region Nothing - ( - "This `case` does not have branches for all possibilities:" - , - D.stack - [ "Missing possibilities include:" - , unhandledPatternsToDocBlock unhandled - , D.reflow $ - "I would have to crash if I saw one of those. Add branches for them!" - , D.link "Hint" - "If you want to write the code for each branch later, use `Debug.todo` as a placeholder. Read" - "missing-patterns" - "for more guidance on this workflow." - ] - ) - - - --- PATTERN TO DOC - - -unhandledPatternsToDocBlock :: [P.Pattern] -> D.Doc -unhandledPatternsToDocBlock unhandledPatterns = - D.indent 4 $ D.dullyellow $ D.vcat $ - map (patternToDoc Unambiguous) unhandledPatterns - - -data Context - = Arg - | Head - | Unambiguous - deriving (Eq) - - -patternToDoc :: Context -> P.Pattern -> D.Doc -patternToDoc context pattern = - case delist pattern [] of - NonList P.Anything -> - "_" - - NonList (P.Literal literal) -> - case literal of - P.Chr chr -> - "'" <> D.fromChars (ES.toChars chr) <> "'" - - P.Str str -> - "\"" <> D.fromChars (ES.toChars str) <> "\"" - - P.Int int -> - D.fromInt int - - NonList (P.Ctor _ "#0" []) -> - "()" - - NonList (P.Ctor _ "#2" [a,b]) -> - "( " <> patternToDoc Unambiguous a <> - ", " <> patternToDoc Unambiguous b <> - " )" - - NonList (P.Ctor _ "#3" [a,b,c]) -> - "( " <> patternToDoc Unambiguous a <> - ", " <> patternToDoc Unambiguous b <> - ", " <> patternToDoc Unambiguous c <> - " )" - - NonList (P.Ctor _ name args) -> - let - ctorDoc = - D.hsep (D.fromName name : map (patternToDoc Arg) args) - in - if context == Arg && length args > 0 then - "(" <> ctorDoc <> ")" - else - ctorDoc - - FiniteList [] -> - "[]" - - FiniteList entries -> - let entryDocs = map (patternToDoc Unambiguous) entries in - "[" <> D.hcat (List.intersperse "," entryDocs) <> "]" - - Conses conses finalPattern -> - let - consDoc = - foldr - (\hd tl -> patternToDoc Head hd <> " :: " <> tl) - (patternToDoc Unambiguous finalPattern) - conses - in - if context == Unambiguous then - consDoc - else - "(" <> consDoc <> ")" - - -data Structure - = FiniteList [P.Pattern] - | Conses [P.Pattern] P.Pattern - | NonList P.Pattern - - -delist :: P.Pattern -> [P.Pattern] -> Structure -delist pattern revEntries = - case pattern of - P.Ctor _ "[]" [] -> - FiniteList revEntries - - P.Ctor _ "::" [hd,tl] -> - delist tl (hd:revEntries) - - _ -> - case revEntries of - [] -> - NonList pattern - - _ -> - Conses (reverse revEntries) pattern diff --git a/compiler/src/Reporting/Error/Syntax.hs b/compiler/src/Reporting/Error/Syntax.hs deleted file mode 100644 index 1070172cf5..0000000000 --- a/compiler/src/Reporting/Error/Syntax.hs +++ /dev/null @@ -1,5848 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE OverloadedStrings #-} -module Reporting.Error.Syntax - ( Error(..) - , toReport - -- - , Module(..) - , Exposing(..) - -- - , Decl(..) - , DeclType(..) - , TypeAlias(..) - , CustomType(..) - , DeclDef(..) - , Port(..) - -- - , Expr(..) - , Record(..) - , Tuple(..) - , List(..) - , Func(..) - , Case(..) - , If(..) - , Let(..) - , Def(..) - , Destruct(..) - -- - , Pattern(..) - , PRecord(..) - , PTuple(..) - , PList(..) - -- - , Type(..) - , TRecord(..) - , TTuple(..) - -- - , Char(..) - , String(..) - , Escape(..) - , Number(..) - -- - , Space(..) - , toSpaceReport - ) - where - - -import Prelude hiding (Char, String) -import qualified Data.Char as Char -import qualified Data.Name as Name -import Data.Word (Word16) -import Numeric (showHex) - -import qualified Elm.ModuleName as ModuleName -import Parse.Primitives (Row, Col) -import Parse.Symbol (BadOperator(..)) -import qualified Reporting.Annotation as A -import qualified Reporting.Doc as D -import qualified Reporting.Report as Report -import qualified Reporting.Render.Code as Code - - - --- ALL SYNTAX ERRORS - - -data Error - = ModuleNameUnspecified ModuleName.Raw - | ModuleNameMismatch ModuleName.Raw (A.Located ModuleName.Raw) - | UnexpectedPort A.Region - | NoPorts A.Region - | NoPortsInPackage (A.Located Name.Name) - | NoPortModulesInPackage A.Region - | NoEffectsOutsideKernel A.Region - | ParseError Module - - - --- MODULE - - -data Module - = ModuleSpace Space Row Col - | ModuleBadEnd Row Col - -- - | ModuleProblem Row Col - | ModuleName Row Col - | ModuleExposing Exposing Row Col - -- - | PortModuleProblem Row Col - | PortModuleName Row Col - | PortModuleExposing Exposing Row Col - -- - | Effect Row Col - -- - | FreshLine Row Col - -- - | ImportStart Row Col - | ImportName Row Col - | ImportAs Row Col - | ImportAlias Row Col - | ImportExposing Row Col - | ImportExposingList Exposing Row Col - | ImportEnd Row Col -- different based on col=1 or if greater - -- - | ImportIndentName Row Col - | ImportIndentAlias Row Col - | ImportIndentExposingList Row Col - -- - | Infix Row Col - -- - | Declarations Decl Row Col - - -data Exposing - = ExposingSpace Space Row Col - | ExposingStart Row Col - | ExposingValue Row Col - | ExposingOperator Row Col - | ExposingOperatorReserved BadOperator Row Col - | ExposingOperatorRightParen Row Col - | ExposingTypePrivacy Row Col - | ExposingEnd Row Col - -- - | ExposingIndentEnd Row Col - | ExposingIndentValue Row Col - - - --- DECLARATIONS - - -data Decl - = DeclStart Row Col - | DeclSpace Space Row Col - -- - | Port Port Row Col - | DeclType DeclType Row Col - | DeclDef Name.Name DeclDef Row Col - -- - | DeclFreshLineAfterDocComment Row Col - - -data DeclDef - = DeclDefSpace Space Row Col - | DeclDefEquals Row Col - | DeclDefType Type Row Col - | DeclDefArg Pattern Row Col - | DeclDefBody Expr Row Col - | DeclDefNameRepeat Row Col - | DeclDefNameMatch Name.Name Row Col - -- - | DeclDefIndentType Row Col - | DeclDefIndentEquals Row Col - | DeclDefIndentBody Row Col - - -data Port - = PortSpace Space Row Col - | PortName Row Col - | PortColon Row Col - | PortType Type Row Col - | PortIndentName Row Col - | PortIndentColon Row Col - | PortIndentType Row Col - - - --- TYPE DECLARATIONS - - -data DeclType - = DT_Space Space Row Col - | DT_Name Row Col - | DT_Alias TypeAlias Row Col - | DT_Union CustomType Row Col - -- - | DT_IndentName Row Col - - -data TypeAlias - = AliasSpace Space Row Col - | AliasName Row Col - | AliasEquals Row Col - | AliasBody Type Row Col - -- - | AliasIndentEquals Row Col - | AliasIndentBody Row Col - - -data CustomType - = CT_Space Space Row Col - | CT_Name Row Col - | CT_Equals Row Col - | CT_Bar Row Col - | CT_Variant Row Col - | CT_VariantArg Type Row Col - -- - | CT_IndentEquals Row Col - | CT_IndentBar Row Col - | CT_IndentAfterBar Row Col - | CT_IndentAfterEquals Row Col - - - --- EXPRESSIONS - - -data Expr - = Let Let Row Col - | Case Case Row Col - | If If Row Col - | List List Row Col - | Record Record Row Col - | Tuple Tuple Row Col - | Func Func Row Col - -- - | Dot Row Col - | Access Row Col - | OperatorRight Name.Name Row Col - | OperatorReserved BadOperator Row Col - -- - | Start Row Col - | Char Char Row Col - | String String Row Col - | Number Number Row Col - | Space Space Row Col - | EndlessShader Row Col - | ShaderProblem [Char.Char] Row Col - | IndentOperatorRight Name.Name Row Col - - -data Record - = RecordOpen Row Col - | RecordEnd Row Col - | RecordField Row Col - | RecordEquals Row Col - | RecordExpr Expr Row Col - | RecordSpace Space Row Col - -- - | RecordIndentOpen Row Col - | RecordIndentEnd Row Col - | RecordIndentField Row Col - | RecordIndentEquals Row Col - | RecordIndentExpr Row Col - - -data Tuple - = TupleExpr Expr Row Col - | TupleSpace Space Row Col - | TupleEnd Row Col - | TupleOperatorClose Row Col - | TupleOperatorReserved BadOperator Row Col - -- - | TupleIndentExpr1 Row Col - | TupleIndentExprN Row Col - | TupleIndentEnd Row Col - - -data List - = ListSpace Space Row Col - | ListOpen Row Col - | ListExpr Expr Row Col - | ListEnd Row Col - -- - | ListIndentOpen Row Col - | ListIndentEnd Row Col - | ListIndentExpr Row Col - - -data Func - = FuncSpace Space Row Col - | FuncArg Pattern Row Col - | FuncBody Expr Row Col - | FuncArrow Row Col - -- - | FuncIndentArg Row Col - | FuncIndentArrow Row Col - | FuncIndentBody Row Col - - -data Case - = CaseSpace Space Row Col - | CaseOf Row Col - | CasePattern Pattern Row Col - | CaseArrow Row Col - | CaseExpr Expr Row Col - | CaseBranch Expr Row Col - -- - | CaseIndentOf Row Col - | CaseIndentExpr Row Col - | CaseIndentPattern Row Col - | CaseIndentArrow Row Col - | CaseIndentBranch Row Col - | CasePatternAlignment Word16 Row Col - - -data If - = IfSpace Space Row Col - | IfThen Row Col - | IfElse Row Col - | IfElseBranchStart Row Col - -- - | IfCondition Expr Row Col - | IfThenBranch Expr Row Col - | IfElseBranch Expr Row Col - -- - | IfIndentCondition Row Col - | IfIndentThen Row Col - | IfIndentThenBranch Row Col - | IfIndentElseBranch Row Col - | IfIndentElse Row Col - - -data Let - = LetSpace Space Row Col - | LetIn Row Col - | LetDefAlignment Word16 Row Col - | LetDefName Row Col - | LetDef Name.Name Def Row Col - | LetDestruct Destruct Row Col - | LetBody Expr Row Col - | LetIndentDef Row Col - | LetIndentIn Row Col - | LetIndentBody Row Col - - -data Def - = DefSpace Space Row Col - | DefType Type Row Col - | DefNameRepeat Row Col - | DefNameMatch Name.Name Row Col - | DefArg Pattern Row Col - | DefEquals Row Col - | DefBody Expr Row Col - | DefIndentEquals Row Col - | DefIndentType Row Col - | DefIndentBody Row Col - | DefAlignment Word16 Row Col - - -data Destruct - = DestructSpace Space Row Col - | DestructPattern Pattern Row Col - | DestructEquals Row Col - | DestructBody Expr Row Col - | DestructIndentEquals Row Col - | DestructIndentBody Row Col - - - --- PATTERNS - - -data Pattern - = PRecord PRecord Row Col - | PTuple PTuple Row Col - | PList PList Row Col - -- - | PStart Row Col - | PChar Char Row Col - | PString String Row Col - | PNumber Number Row Col - | PFloat Word16 Row Col - | PAlias Row Col - | PWildcardNotVar Name.Name Int Row Col - | PSpace Space Row Col - -- - | PIndentStart Row Col - | PIndentAlias Row Col - - -data PRecord - = PRecordOpen Row Col - | PRecordEnd Row Col - | PRecordField Row Col - | PRecordSpace Space Row Col - -- - | PRecordIndentOpen Row Col - | PRecordIndentEnd Row Col - | PRecordIndentField Row Col - - -data PTuple - = PTupleOpen Row Col - | PTupleEnd Row Col - | PTupleExpr Pattern Row Col - | PTupleSpace Space Row Col - -- - | PTupleIndentEnd Row Col - | PTupleIndentExpr1 Row Col - | PTupleIndentExprN Row Col - - -data PList - = PListOpen Row Col - | PListEnd Row Col - | PListExpr Pattern Row Col - | PListSpace Space Row Col - -- - | PListIndentOpen Row Col - | PListIndentEnd Row Col - | PListIndentExpr Row Col - - - --- TYPES - - -data Type - = TRecord TRecord Row Col - | TTuple TTuple Row Col - -- - | TStart Row Col - | TSpace Space Row Col - -- - | TIndentStart Row Col - - -data TRecord - = TRecordOpen Row Col - | TRecordEnd Row Col - -- - | TRecordField Row Col - | TRecordColon Row Col - | TRecordType Type Row Col - -- - | TRecordSpace Space Row Col - -- - | TRecordIndentOpen Row Col - | TRecordIndentField Row Col - | TRecordIndentColon Row Col - | TRecordIndentType Row Col - | TRecordIndentEnd Row Col - - -data TTuple - = TTupleOpen Row Col - | TTupleEnd Row Col - | TTupleType Type Row Col - | TTupleSpace Space Row Col - -- - | TTupleIndentType1 Row Col - | TTupleIndentTypeN Row Col - | TTupleIndentEnd Row Col - - - --- LITERALS - - -data Char - = CharEndless - | CharEscape Escape - | CharNotString Word16 - - -data String - = StringEndless_Single - | StringEndless_Multi - | StringEscape Escape - - -data Escape - = EscapeUnknown - | BadUnicodeFormat Word16 - | BadUnicodeCode Word16 - | BadUnicodeLength Word16 Int Int - - -data Number - = NumberEnd - | NumberDot Int - | NumberHexDigit - | NumberNoLeadingZero - - - --- MISC - - -data Space - = HasTab - | EndlessMultiComment - - - --- TO REPORT - - -toReport :: Code.Source -> Error -> Report.Report -toReport source err = - case err of - ModuleNameUnspecified name -> - let - region = toRegion 1 1 - in - Report.Report "MODULE NAME MISSING" region [] $ - D.stack - [ D.reflow $ - "I need the module name to be declared at the top of this file, like this:" - , D.indent 4 $ D.fillSep $ - [ D.cyan "module", D.fromName name, D.cyan "exposing", "(..)" ] - , D.reflow $ - "Try adding that as the first line of your file!" - , D.toSimpleNote $ - "It is best to replace (..) with an explicit list of types and\ - \ functions you want to expose. When you know a value is only used\ - \ within this module, you can refactor without worrying about uses\ - \ elsewhere. Limiting exposed values can also speed up compilation\ - \ because I can skip a bunch of work if I see that the exposed API\ - \ has not changed." - ] - - ModuleNameMismatch expectedName (A.At region actualName) -> - Report.Report "MODULE NAME MISMATCH" region [ModuleName.toChars expectedName] $ - Code.toSnippet source region Nothing - ( - "It looks like this module name is out of sync:" - , - D.stack - [ D.reflow $ - "I need it to match the file path, so I was expecting to see `" - ++ ModuleName.toChars expectedName - ++ "` here. Make the following change, and you should be all set!" - , D.indent 4 $ - D.dullyellow (D.fromName actualName) <> " -> " <> D.green (D.fromName expectedName) - , D.toSimpleNote $ - "I require that module names correspond to file paths. This makes it much\ - \ easier to explore unfamiliar codebases! So if you want to keep the current\ - \ module name, try renaming the file instead." - ] - ) - - UnexpectedPort region -> - Report.Report "UNEXPECTED PORTS" region [] $ - Code.toSnippet source region Nothing - ( - D.reflow $ - "You are declaring ports in a normal module." - , - D.stack - [ D.fillSep - ["Switch","this","to","say",D.cyan "port module","instead," - ,"marking","that","this","module","contains","port","declarations." - ] - , D.link "Note" - "Ports are not a traditional FFI for calling JS functions directly. They need a different mindset! Read" - "ports" - "to learn the syntax and how to use it effectively." - ] - ) - - NoPorts region -> - Report.Report "NO PORTS" region [] $ - Code.toSnippet source region Nothing - ( - D.reflow $ - "This module does not declare any ports, but it says it will:" - , - D.fillSep - ["Switch","this","to",D.cyan "module" - ,"and","you","should","be","all","set!" - ] - ) - - NoPortsInPackage (A.At region _) -> - Report.Report "PACKAGES CANNOT HAVE PORTS" region [] $ - Code.toSnippet source region Nothing - ( - D.reflow $ - "Packages cannot declare any ports, so I am getting stuck here:" - , - D.stack - [ D.reflow $ - "Remove this port declaration." - , noteForPortsInPackage - ] - ) - - NoPortModulesInPackage region -> - Report.Report "PACKAGES CANNOT HAVE PORTS" region [] $ - Code.toSnippet source region Nothing - ( - D.reflow $ - "Packages cannot declare any ports, so I am getting stuck here:" - , - D.stack - [ D.fillSep $ - ["Remove","the",D.cyan "port","keyword","and","I" - ,"should","be","able","to","continue." - ] - , noteForPortsInPackage - ] - ) - - NoEffectsOutsideKernel region -> - Report.Report "INVALID EFFECT MODULE" region [] $ - Code.toSnippet source region Nothing - ( - D.reflow $ - "It is not possible to declare an `effect module` outside the @elm organization,\ - \ so I am getting stuck here:" - , - D.stack - [ D.reflow $ - "Switch to a normal module declaration." - , D.toSimpleNote $ - "Effect modules are designed to allow certain core functionality to be\ - \ defined separately from the compiler. So the @elm organization has access to\ - \ this so that certain changes, extensions, and fixes can be introduced without\ - \ needing to release new Elm binaries. For example, we want to make it possible\ - \ to test effects, but this may require changes to the design of effect modules.\ - \ By only having them defined in the @elm organization, that kind of design work\ - \ can proceed much more smoothly." - ] - ) - - ParseError modul -> - toParseErrorReport source modul - - -noteForPortsInPackage :: D.Doc -noteForPortsInPackage = - D.stack - [ D.toSimpleNote $ - "One of the major goals of the package ecosystem is to be completely written\ - \ in Elm. This means when you install an Elm package, you can be sure you are safe\ - \ from security issues on install and that you are not going to get any runtime\ - \ exceptions coming from your new dependency. This design also sets the ecosystem\ - \ up to target other platforms more easily (like mobile phones, WebAssembly, etc.)\ - \ since no community code explicitly depends on JavaScript even existing." - , D.reflow $ - "Given that overall goal, allowing ports in packages would lead to some pretty\ - \ surprising behavior. If ports were allowed in packages, you could install a\ - \ package but not realize that it brings in an indirect dependency that defines a\ - \ port. Now you have a program that does not work and the fix is to realize that\ - \ some JavaScript needs to be added for a dependency you did not even know about.\ - \ That would be extremely frustrating! \"So why not allow the package author to\ - \ include the necessary JS code as well?\" Now we are back in conflict with our\ - \ overall goal to keep all community packages free from runtime exceptions." - ] - - -toParseErrorReport :: Code.Source -> Module -> Report.Report -toParseErrorReport source modul = - case modul of - ModuleSpace space row col -> - toSpaceReport source space row col - - ModuleBadEnd row col -> - if col == 1 - then toDeclStartReport source row col - else toWeirdEndReport source row col - - ModuleProblem row col -> - let - region = toRegion row col - in - Report.Report "UNFINISHED MODULE DECLARATION" region [] $ - Code.toSnippet source region Nothing - ( - D.reflow $ - "I am parsing an `module` declaration, but I got stuck here:" - , - D.stack - [ D.reflow $ - "Here are some examples of valid `module` declarations:" - , D.indent 4 $ D.vcat $ - [ D.fillSep [D.cyan "module","Main",D.cyan "exposing","(..)"] - , D.fillSep [D.cyan "module","Dict",D.cyan "exposing","(Dict, empty, get)"] - ] - , D.reflow $ - "I generally recommend using an explicit exposing list. I can skip compiling a bunch\ - \ of files when the public interface of a module stays the same, so exposing fewer\ - \ values can help improve compile times!" - ] - ) - - ModuleName row col -> - let - region = toRegion row col - in - Report.Report "EXPECTING MODULE NAME" region [] $ - Code.toSnippet source region Nothing - ( - D.reflow $ - "I was parsing an `module` declaration until I got stuck here:" - , - D.stack - [ D.reflow $ - "I was expecting to see the module name next, like in these examples:" - , D.indent 4 $ D.vcat $ - [ D.fillSep [D.cyan "module","Dict",D.cyan "exposing","(..)"] - , D.fillSep [D.cyan "module","Maybe",D.cyan "exposing","(..)"] - , D.fillSep [D.cyan "module","Html.Attributes",D.cyan "exposing","(..)"] - , D.fillSep [D.cyan "module","Json.Decode",D.cyan "exposing","(..)"] - ] - , D.reflow $ - "Notice that the module names all start with capital letters. That is required!" - ] - ) - - ModuleExposing exposing row col -> - toExposingReport source exposing row col - - PortModuleProblem row col -> - let - region = toRegion row col - in - Report.Report "UNFINISHED PORT MODULE DECLARATION" region [] $ - Code.toSnippet source region Nothing - ( - D.reflow $ - "I am parsing an `port module` declaration, but I got stuck here:" - , - D.stack - [ D.reflow $ - "Here are some examples of valid `port module` declarations:" - , D.indent 4 $ D.vcat $ - [ D.fillSep [D.cyan "port",D.cyan "module","WebSockets",D.cyan "exposing","(send, listen, keepAlive)"] - , D.fillSep [D.cyan "port",D.cyan "module","Maps",D.cyan "exposing","(Location, goto)"] - ] - , D.link "Note" "Read" "ports" "for more help." - ] - ) - - PortModuleName row col -> - let - region = toRegion row col - in - Report.Report "EXPECTING MODULE NAME" region [] $ - Code.toSnippet source region Nothing - ( - D.reflow $ - "I was parsing an `module` declaration until I got stuck here:" - , - D.stack - [ D.reflow $ - "I was expecting to see the module name next, like in these examples:" - , D.indent 4 $ D.vcat $ - [ D.fillSep [D.cyan "port",D.cyan "module","WebSockets",D.cyan "exposing","(send, listen, keepAlive)"] - , D.fillSep [D.cyan "port",D.cyan "module","Maps",D.cyan "exposing","(Location, goto)"] - ] - , D.reflow $ - "Notice that the module names start with capital letters. That is required!" - ] - ) - - PortModuleExposing exposing row col -> - toExposingReport source exposing row col - - Effect row col -> - let - region = toRegion row col - in - Report.Report "BAD MODULE DECLARATION" region [] $ - Code.toSnippet source region Nothing - ( - D.reflow $ - "I cannot parse this module declaration:" - , - D.reflow $ - "This type of module is reserved for the @elm organization. It is used to\ - \ define certain effects, avoiding building them into the compiler." - ) - - FreshLine row col -> - let - region = toRegion row col - - toBadFirstLineReport keyword = - Report.Report "TOO MUCH INDENTATION" region [] $ - Code.toSnippet source region Nothing - ( - D.reflow $ - "This `" ++ keyword ++ "` should not have any spaces before it:" - , - D.reflow $ - "Delete the spaces before `" ++ keyword ++ "` until there are none left!" - ) - - in - case Code.whatIsNext source row col of - Code.Keyword "module" -> toBadFirstLineReport "module" - Code.Keyword "import" -> toBadFirstLineReport "import" - Code.Keyword "type" -> toBadFirstLineReport "type" - Code.Keyword "port" -> toBadFirstLineReport "port" - _ -> - Report.Report "SYNTAX PROBLEM" region [] $ - Code.toSnippet source region Nothing - ( - D.reflow $ - "I got stuck here:" - , - D.stack - [ D.reflow $ - "I am not sure what is going on, but I recommend starting an Elm\ - \ file with the following lines:" - , D.indent 4 $ D.vcat $ - [ D.fillSep [D.cyan "import","Html"] - , "" - , "main =" - , " Html.text " <> D.dullyellow "\"Hello!\"" - ] - , D.reflow $ - "You should be able to copy those lines directly into your file. Check out the\ - \ examples at for more help getting started!" - , D.toSimpleNote $ - "This can also happen when something is indented too much!" - ] - ) - - ImportStart row col -> - toImportReport source row col - - ImportName row col -> - let - region = toRegion row col - in - Report.Report "EXPECTING IMPORT NAME" region [] $ - Code.toSnippet source region Nothing - ( - D.reflow $ - "I was parsing an `import` until I got stuck here:" - , - D.stack - [ D.reflow $ - "I was expecting to see a module name next, like in these examples:" - , D.indent 4 $ D.vcat $ - [ D.fillSep [D.cyan "import","Dict"] - , D.fillSep [D.cyan "import","Maybe"] - , D.fillSep [D.cyan "import","Html.Attributes",D.cyan "as","A"] - , D.fillSep [D.cyan "import","Json.Decode",D.cyan "exposing","(..)"] - ] - , D.reflow $ - "Notice that the module names all start with capital letters. That is required!" - , D.reflowLink "Read" "imports" "to learn more." - ] - ) - - ImportAs row col -> - toImportReport source row col - - ImportAlias row col -> - let - region = toRegion row col - in - Report.Report "EXPECTING IMPORT ALIAS" region [] $ - Code.toSnippet source region Nothing - ( - D.reflow $ - "I was parsing an `import` until I got stuck here:" - , - D.stack - [ D.reflow $ - "I was expecting to see an alias next, like in these examples:" - , D.indent 4 $ D.vcat $ - [ D.fillSep [D.cyan "import","Html.Attributes",D.cyan "as","Attr"] - , D.fillSep [D.cyan "import","WebGL.Texture",D.cyan "as","Texture"] - , D.fillSep [D.cyan "import","Json.Decode",D.cyan "as","D"] - ] - , D.reflow $ - "Notice that the alias always starts with a capital letter. That is required!" - , D.reflowLink "Read" "imports" "to learn more." - ] - ) - - ImportExposing row col -> - toImportReport source row col - - ImportExposingList exposing row col -> - toExposingReport source exposing row col - - ImportEnd row col -> - toImportReport source row col - - ImportIndentName row col -> - toImportReport source row col - - ImportIndentAlias row col -> - toImportReport source row col - - ImportIndentExposingList row col -> - let - region = toRegion row col - in - Report.Report "UNFINISHED IMPORT" region [] $ - Code.toSnippet source region Nothing - ( - D.reflow $ - "I was parsing an `import` until I got stuck here:" - , - D.stack - [ D.reflow $ - "I was expecting to see the list of exposed values next. For example, here\ - \ are two ways to expose values from the `Html` module:" - , D.indent 4 $ D.vcat $ - [ D.fillSep [D.cyan "import","Html",D.cyan "exposing","(..)"] - , D.fillSep [D.cyan "import","Html",D.cyan "exposing","(Html, div, text)"] - ] - , D.reflow $ - "I generally recommend the second style. It is more explicit, making it\ - \ much easier to figure out where values are coming from in large projects!" - ] - ) - - Infix row col -> - let - region = toRegion row col - in - Report.Report "BAD INFIX" region [] $ - Code.toSnippet source region Nothing - ( - D.reflow $ - "Something went wrong in this infix operator declaration:" - , - D.reflow $ - "This feature is used by the @elm organization to define the\ - \ languages built-in operators." - ) - - Declarations decl _ _ -> - toDeclarationsReport source decl - - - --- WEIRD END - - -toWeirdEndReport :: Code.Source -> Row -> Col -> Report.Report -toWeirdEndReport source row col = - case Code.whatIsNext source row col of - Code.Keyword keyword -> - let - region = toKeywordRegion row col keyword - in - Report.Report "RESERVED WORD" region [] $ - Code.toSnippet source region Nothing - ( - D.reflow $ - "I got stuck on this reserved word:" - , - D.reflow $ - "The name `" ++ keyword ++ "` is reserved, so try using a different name?" - ) - - Code.Operator op -> - let - region = toKeywordRegion row col op - in - Report.Report "UNEXPECTED SYMBOL" region [] $ - Code.toSnippet source region Nothing - ( - D.reflow $ - "I ran into an unexpected symbol:" - , - D.reflow $ - "I was not expecting to see a " ++ op ++ " here. Try deleting it? Maybe\ - \ I can give a better hint from there?" - ) - - Code.Close term bracket -> - let - region = toRegion row col - in - Report.Report ("UNEXPECTED " ++ map Char.toUpper term) region [] $ - Code.toSnippet source region Nothing - ( - D.reflow $ - "I ran into an unexpected " ++ term ++ ":" - , - D.reflow $ - "This " ++ bracket : " does not match up with an earlier open " ++ term ++ ". Try deleting it?" - ) - - Code.Lower c cs -> - let - region = toKeywordRegion row col (c:cs) - in - Report.Report "UNEXPECTED NAME" region [] $ - Code.toSnippet source region Nothing - ( - D.reflow $ - "I got stuck on this name:" - , - D.reflow $ - "It is confusing me a lot! Normally I can give fairly specific hints, but\ - \ something is really tripping me up this time." - ) - - Code.Upper c cs -> - let - region = toKeywordRegion row col (c:cs) - in - Report.Report "UNEXPECTED NAME" region [] $ - Code.toSnippet source region Nothing - ( - D.reflow $ - "I got stuck on this name:" - , - D.reflow $ - "It is confusing me a lot! Normally I can give fairly specific hints, but\ - \ something is really tripping me up this time." - ) - - Code.Other maybeChar -> - let - region = toRegion row col - in - case maybeChar of - Just ';' -> - Report.Report "UNEXPECTED SEMICOLON" region [] $ - Code.toSnippet source region Nothing - ( - D.reflow $ - "I got stuck on this semicolon:" - , - D.stack - [ D.reflow $ "Try removing it?" - , D.toSimpleNote $ - "Some languages require semicolons at the end of each statement. These are\ - \ often called C-like languages, and they usually share a lot of language design\ - \ choices. (E.g. side-effects, for loops, etc.) Elm manages effects with commands\ - \ and subscriptions instead, so there is no special syntax for \"statements\" and\ - \ therefore no need to use semicolons to separate them. I think this will make\ - \ more sense as you work through though!" - ] - ) - - Just ',' -> - Report.Report "UNEXPECTED COMMA" region [] $ - Code.toSnippet source region Nothing - ( - D.reflow $ - "I got stuck on this comma:" - , - D.stack - [ D.reflow $ - "I do not think I am parsing a list or tuple right now. Try deleting the comma?" - , D.toSimpleNote $ - "If this is supposed to be part of a list, the problem may be a bit earlier.\ - \ Perhaps the opening [ is missing? Or perhaps some value in the list has an extra\ - \ closing ] that is making me think the list ended earlier? The same kinds of\ - \ things could be going wrong if this is supposed to be a tuple." - ] - ) - - Just '`' -> - Report.Report "UNEXPECTED CHARACTER" region [] $ - Code.toSnippet source region Nothing - ( - D.reflow $ - "I got stuck on this character:" - , - D.stack - [ D.reflow $ - "It is not used for anything in Elm syntax. It is used for multi-line strings in\ - \ some languages though, so if you want a string that spans multiple lines, you\ - \ can use Elm's multi-line string syntax like this:" - , D.dullyellow $ D.indent 4 $ D.vcat $ - [ "\"\"\"" - , "# Multi-line Strings" - , "" - , "- start with triple double quotes" - , "- write whatever you want" - , "- no need to escape newlines or double quotes" - , "- end with triple double quotes" - , "\"\"\"" - ] - , D.reflow $ - "Otherwise I do not know what is going on! Try removing the character?" - ] - ) - - Just '$' -> - Report.Report "UNEXPECTED SYMBOL" region [] $ - Code.toSnippet source region Nothing - ( - D.reflow $ - "I got stuck on this dollar sign:" - , - D.reflow $ - "It is not used for anything in Elm syntax. Are you coming from a language where\ - \ dollar signs can be used in variable names? If so, try a name that (1) starts\ - \ with a letter and (2) only contains letters, numbers, and underscores." - ) - - Just c | elem c ['#','@','!','%','~'] -> - Report.Report "UNEXPECTED SYMBOL" region [] $ - Code.toSnippet source region Nothing - ( - D.reflow $ - "I got stuck on this symbol:" - , - D.reflow $ - "It is not used for anything in Elm syntax. Try removing it?" - ) - - _ -> - Report.Report "SYNTAX PROBLEM" region [] $ - Code.toSnippet source region Nothing - ( - D.reflow $ - "I got stuck here:" - , - D.reflow $ - "Whatever I am running into is confusing me a lot! Normally I can give fairly\ - \ specific hints, but something is really tripping me up this time." - ) - - - --- IMPORTS - - -toImportReport :: Code.Source -> Row -> Col -> Report.Report -toImportReport source row col = - let - region = toRegion row col - in - Report.Report "UNFINISHED IMPORT" region [] $ - Code.toSnippet source region Nothing - ( - D.reflow $ - "I am partway through parsing an import, but I got stuck here:" - , - D.stack - [ D.reflow $ - "Here are some examples of valid `import` declarations:" - , D.indent 4 $ D.vcat $ - [ D.fillSep [D.cyan "import","Html"] - , D.fillSep [D.cyan "import","Html",D.cyan "as","H"] - , D.fillSep [D.cyan "import","Html",D.cyan "as","H",D.cyan "exposing","(..)"] - , D.fillSep [D.cyan "import","Html",D.cyan "exposing","(Html, div, text)"] - ] - , D.reflow $ - "You are probably trying to import a different module, but try to make it look like one of these examples!" - , D.reflowLink "Read" "imports" "to learn more." - ] - ) - - - --- EXPOSING - - -toExposingReport :: Code.Source -> Exposing -> Row -> Col -> Report.Report -toExposingReport source exposing startRow startCol = - case exposing of - ExposingSpace space row col -> - toSpaceReport source space row col - - ExposingStart row col -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - in - Report.Report "PROBLEM IN EXPOSING" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I want to parse exposed values, but I am getting stuck here:" - , - D.stack - [ D.fillSep $ - ["Exposed","values","are","always","surrounded","by","parentheses." - ,"So","try","adding","a",D.green "(","here?" - ] - , D.toSimpleNote "Here are some valid examples of `exposing` for reference:" - , D.indent 4 $ D.vcat $ - [ D.fillSep [D.cyan "import","Html",D.cyan "exposing","(..)"] - , D.fillSep [D.cyan "import","Html",D.cyan "exposing","(Html, div, text)"] - ] - , D.reflow $ - "If you are getting tripped up, you can just expose everything for now. It should\ - \ get easier to make an explicit exposing list as you see more examples in the wild." - ] - ) - - ExposingValue row col -> - case Code.whatIsNext source row col of - Code.Keyword keyword -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toKeywordRegion row col keyword - in - Report.Report "RESERVED WORD" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I got stuck on this reserved word:" - , - D.reflow $ - "It looks like you are trying to expose `" ++ keyword ++ "` but that is a reserved word. Is there a typo?" - ) - - Code.Operator op -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toKeywordRegion row col op - in - Report.Report "UNEXPECTED SYMBOL" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I got stuck on this symbol:" - , - D.stack - [ D.reflow $ - "If you are trying to expose an operator, add parentheses around it like this:" - , D.indent 4 $ D.dullyellow (D.fromChars op) <> " -> " <> D.green ("(" <> D.fromChars op <> ")") - ] - ) - - _ -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - in - Report.Report "PROBLEM IN EXPOSING" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I got stuck while parsing these exposed values:" - , - D.stack - [ D.reflow $ - "I do not have an exact recommendation, so here are some valid examples\ - \ of `exposing` for reference:" - , D.indent 4 $ D.vcat $ - [ D.fillSep [D.cyan "import","Html",D.cyan "exposing","(..)"] - , D.fillSep [D.cyan "import","Basics",D.cyan "exposing","(Int, Float, Bool(..), (+), not, sqrt)"] - ] - , D.reflow $ - "These examples show how to expose types, variants, operators, and functions. Everything\ - \ should be some permutation of these examples, just with different names." - ] - ) - - ExposingOperator row col -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - in - Report.Report "PROBLEM IN EXPOSING" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I just saw an open parenthesis, so I was expecting an operator next:" - , - D.fillSep $ - ["It","is","possible","to","expose","operators,","so","I","was","expecting" - ,"to","see","something","like",D.dullyellow "(+)","or",D.dullyellow "(|=)" - ,"or",D.dullyellow "(||)","after","I","saw","that","open","parenthesis." - ] - ) - - ExposingOperatorReserved op row col -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - in - Report.Report "RESERVED SYMBOL" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I cannot expose this as an operator:" - , - case op of - BadDot -> D.reflow "Try getting rid of this entry? Maybe I can give you a better hint after that?" - BadPipe -> D.fillSep ["Maybe","you","want",D.dullyellow "(||)","instead?"] - BadArrow -> D.reflow "Try getting rid of this entry? Maybe I can give you a better hint after that?" - BadEquals -> D.fillSep ["Maybe","you","want",D.dullyellow "(==)","instead?"] - BadHasType -> D.fillSep ["Maybe","you","want",D.dullyellow "(::)","instead?"] - ) - - ExposingOperatorRightParen row col -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - in - Report.Report "PROBLEM IN EXPOSING" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "It looks like you are exposing an operator, but I got stuck here:" - , - D.fillSep $ - ["I","was","expecting","to","see","the","closing","parenthesis","immediately" - ,"after","the","operator.","Try","adding","a",D.green ")","right","here?" - ] - ) - - ExposingEnd row col -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - in - Report.Report "UNFINISHED EXPOSING" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I was partway through parsing exposed values, but I got stuck here:" - , - D.reflow $ - "Maybe there is a comma missing before this?" - ) - - ExposingTypePrivacy row col -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - in - Report.Report "PROBLEM EXPOSING CUSTOM TYPE VARIANTS" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "It looks like you are trying to expose the variants of a custom type:" - , - D.stack - [ D.fillSep $ - ["You","need","to","write","something","like" - ,D.dullyellow "Status(..)","or",D.dullyellow "Entity(..)" - ,"though.","It","is","all","or","nothing,","otherwise","`case`" - ,"expressions","could","miss","a","variant","and","crash!" - ] - , D.toSimpleNote $ - "It is often best to keep the variants hidden! If someone pattern matches on\ - \ the variants, it is a MAJOR change if any new variants are added. Suddenly\ - \ their `case` expressions do not cover all variants! So if you do not need\ - \ people to pattern match, keep the variants hidden and expose functions to\ - \ construct values of this type. This way you can add new variants as a MINOR change!" - ] - ) - - ExposingIndentEnd row col -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - in - Report.Report "UNFINISHED EXPOSING" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I was partway through parsing exposed values, but I got stuck here:" - , - D.stack - [ D.fillSep $ - ["I","was","expecting","a","closing","parenthesis." - ,"Try","adding","a",D.green ")","right","here?" - ] - , D.toSimpleNote $ - "I can get confused when there is not enough indentation, so if you already\ - \ have a closing parenthesis, it probably just needs some spaces in front of it." - ] - ) - - ExposingIndentValue row col -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - in - Report.Report "UNFINISHED EXPOSING" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I was partway through parsing exposed values, but I got stuck here:" - , - D.reflow $ - "I was expecting another value to expose." - ) - - - --- SPACES - - -toSpaceReport :: Code.Source -> Space -> Row -> Col -> Report.Report -toSpaceReport source space row col = - case space of - HasTab -> - let - region = toRegion row col - in - Report.Report "NO TABS" region [] $ - Code.toSnippet source region Nothing - ( - D.reflow $ - "I ran into a tab, but tabs are not allowed in Elm files." - , - D.reflow $ - "Replace the tab with spaces." - ) - - EndlessMultiComment -> - let - region = toWiderRegion row col 2 - in - Report.Report "ENDLESS COMMENT" region [] $ - Code.toSnippet source region Nothing - ( - D.reflow $ - "I cannot find the end of this multi-line comment:" - , - D.stack -- "{-" - [ D.reflow "Add a -} somewhere after this to end the comment." - , D.toSimpleHint - "Multi-line comments can be nested in Elm, so {- {- -} -} is a comment\ - \ that happens to contain another comment. Like parentheses and curly braces,\ - \ the start and end markers must always be balanced. Maybe that is the problem?" - ] - ) - - - --- DECLARATIONS - - -toRegion :: Row -> Col -> A.Region -toRegion row col = - let - pos = A.Position row col - in - A.Region pos pos - - -toWiderRegion :: Row -> Col -> Word16 -> A.Region -toWiderRegion row col extra = - A.Region - (A.Position row col) - (A.Position row (col + extra)) - - -toKeywordRegion :: Row -> Col -> [Char.Char] -> A.Region -toKeywordRegion row col keyword = - A.Region - (A.Position row col) - (A.Position row (col + fromIntegral (length keyword))) - - -toDeclarationsReport :: Code.Source -> Decl -> Report.Report -toDeclarationsReport source decl = - case decl of - DeclStart row col -> - toDeclStartReport source row col - - DeclSpace space row col -> - toSpaceReport source space row col - - Port port_ row col -> - toPortReport source port_ row col - - DeclType declType row col -> - toDeclTypeReport source declType row col - - DeclDef name declDef row col -> - toDeclDefReport source name declDef row col - - DeclFreshLineAfterDocComment row col -> - let - region = toRegion row col - in - Report.Report "EXPECTING DECLARATION" region [] $ - Code.toSnippet source region Nothing - ( - D.reflow $ - "I just saw a doc comment, but then I got stuck here:" - , - D.reflow $ - "I was expecting to see the corresponding declaration next, starting on a fresh\ - \ line with no indentation." - ) - - -toDeclStartReport :: Code.Source -> Row -> Col -> Report.Report -toDeclStartReport source row col = - case Code.whatIsNext source row col of - Code.Close term bracket -> - let - region = toRegion row col - in - Report.Report ("STRAY " ++ map Char.toUpper term) region [] $ - Code.toSnippet source region Nothing - ( - D.reflow $ - "I was not expecting to see a " ++ term ++ " here:" - , D.reflow $ - "This " ++ bracket : " does not match up with an earlier open " ++ term ++ ". Try deleting it?" - ) - - Code.Keyword keyword -> - let - region = toKeywordRegion row col keyword - in - Report.Report "RESERVED WORD" region [] $ - Code.toSnippet source region Nothing - ( - D.reflow $ - "I was not expecting to run into the `" ++ keyword ++ "` keyword here:" - , - case keyword of - "import" -> - D.reflow $ - "It is reserved for declaring imports at the top of your module. If you want\ - \ another import, try moving it up top with the other imports. If you want to\ - \ define a value or function, try changing the name to something else!" - - "case" -> - D.stack - [ D.reflow $ - "It is reserved for writing `case` expressions. Try using a different name?" - , D.toSimpleNote $ - "If you are trying to write a `case` expression, it needs to be part of a\ - \ definition. So you could write something like this instead:" - , D.indent 4 $ D.vcat $ - [ D.indent 0 $ D.fillSep ["getWidth","maybeWidth","="] - , D.indent 2 $ D.fillSep [D.cyan "case","maybeWidth",D.cyan "of"] - , D.indent 4 $ D.fillSep [D.blue "Just","width","->"] - , D.indent 6 $ D.fillSep ["width","+",D.dullyellow "200"] - , "" - , D.indent 4 $ D.fillSep [D.blue "Nothing","->"] - , D.indent 6 $ D.fillSep [D.dullyellow "400"] - ] - , D.reflow $ - "This defines a `getWidth` function that you can use elsewhere in your program." - ] - - "if" -> - D.stack - [ D.reflow $ - "It is reserved for writing `if` expressions. Try using a different name?" - , D.toSimpleNote $ - "If you are trying to write an `if` expression, it needs to be part of a\ - \ definition. So you could write something like this instead:" - , D.indent 4 $ D.vcat $ - [ "greet name =" - , D.fillSep $ - [" " - ,D.cyan "if","name","==",D.dullyellow "\"Abraham Lincoln\"" - ,D.cyan "then",D.dullyellow "\"Greetings Mr. President.\"" - ,D.cyan "else",D.dullyellow "\"Hey!\"" - ] - ] - , D.reflow $ - "This defines a `reviewPowerLevel` function that you can use elsewhere in your program." - ] - - _ -> - D.reflow $ - "It is a reserved word. Try changing the name to something else?" - ) - - Code.Upper c cs -> - let - region = toRegion row col - in - Report.Report "UNEXPECTED CAPITAL LETTER" region [] $ - Code.toSnippet source region Nothing - ( - D.reflow $ - "Declarations always start with a lower-case letter, so I am getting stuck here:" - , - D.stack - [ D.fillSep $ - ["Try","a","name","like" - ,D.green (D.fromChars (Char.toLower c : cs)) - ,"instead?" - ] - , D.toSimpleNote $ - "Here are a couple valid declarations for reference:" - , D.indent 4 $ D.vcat $ - [ "greet : String -> String" - , "greet name =" - , " " <> D.dullyellow "\"Hello \"" <> " ++ name ++ " <> D.dullyellow "\"!\"" - , "" - , D.cyan "type" <> " User = Anonymous | LoggedIn String" - ] - , D.reflow $ - "Notice that they always start with a lower-case letter. Capitalization matters!" - ] - ) - - Code.Other (Just char) | elem char ['(', '{', '[', '+', '-', '*', '/', '^', '&', '|', '"', '\'', '!', '@', '#', '$', '%'] -> - let - region = toRegion row col - in - Report.Report "UNEXPECTED SYMBOL" region [] $ - Code.toSnippet source region Nothing - ( - D.reflow $ - "I am getting stuck because this line starts with the " ++ [char] ++ " symbol:" - , - D.stack - [ D.reflow $ - "When a line has no spaces at the beginning, I expect it to be a declaration like one of these:" - , D.indent 4 $ D.vcat $ - [ "greet : String -> String" - , "greet name =" - , " " <> D.dullyellow "\"Hello \"" <> " ++ name ++ " <> D.dullyellow "\"!\"" - , "" - , D.cyan "type" <> " User = Anonymous | LoggedIn String" - ] - , D.reflow $ - "If this is not supposed to be a declaration, try adding some spaces before it?" - ] - ) - - _ -> - let - region = toRegion row col - in - Report.Report "WEIRD DECLARATION" region [] $ - Code.toSnippet source region Nothing - ( - D.reflow $ - "I am trying to parse a declaration, but I am getting stuck here:" - , - D.stack - [ D.reflow $ - "When a line has no spaces at the beginning, I expect it to be a declaration like one of these:" - , D.indent 4 $ D.vcat $ - [ "greet : String -> String" - , "greet name =" - , " " <> D.dullyellow "\"Hello \"" <> " ++ name ++ " <> D.dullyellow "\"!\"" - , "" - , D.cyan "type" <> " User = Anonymous | LoggedIn String" - ] - , D.reflow $ - "Try to make your declaration look like one of those? Or if this is not\ - \ supposed to be a declaration, try adding some spaces before it?" - ] - ) - - --- PORT - - -toPortReport :: Code.Source -> Port -> Row -> Col -> Report.Report -toPortReport source port_ startRow startCol = - case port_ of - PortSpace space row col -> - toSpaceReport source space row col - - PortName row col -> - case Code.whatIsNext source row col of - Code.Keyword keyword -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toKeywordRegion row col keyword - in - Report.Report "RESERVED WORD" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I cannot handle ports with names like this:" - , - D.reflow $ - "You are trying to make a port named `" ++ keyword - ++ "` but that is a reserved word. Try using some other name?" - ) - - _ -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - in - Report.Report "PORT PROBLEM" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I just saw the start of a `port` declaration, but then I got stuck here:" - , - D.stack - [ D.fillSep - ["I","was","expecting","to","see","a","name","like" - ,D.dullyellow "send","or",D.dullyellow "receive","next." - ,"Something","that","starts","with","a","lower-case","letter." - ] - , portNote - ] - ) - - PortColon row col -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - in - Report.Report "PORT PROBLEM" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I just saw the start of a `port` declaration, but then I got stuck here:" - , - D.stack - [ D.reflow $ - "I was expecting to see a colon next. And then a type that tells me\ - \ what type of values are going to flow through." - , portNote - ] - ) - - PortType tipe row col -> - toTypeReport source TC_Port tipe row col - - PortIndentName row col -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - in - Report.Report "UNFINISHED PORT" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I just saw the start of a `port` declaration, but then I got stuck here:" - , - D.stack - [ D.fillSep - ["I","was","expecting","to","see","a","name","like" - ,D.dullyellow "send","or",D.dullyellow "receive","next." - ,"Something","that","starts","with","a","lower-case","letter." - ] - , portNote - ] - ) - - PortIndentColon row col -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - in - Report.Report "UNFINISHED PORT" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I just saw the start of a `port` declaration, but then I got stuck here:" - , - D.stack - [ D.reflow $ - "I was expecting to see a colon next. And then a type that tells me\ - \ what type of values are going to flow through." - , portNote - ] - ) - - PortIndentType row col -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - in - Report.Report "UNFINISHED PORT" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I just saw the start of a `port` declaration, but then I got stuck here:" - , - D.stack - [ D.reflow $ - "I was expecting to see a type next. Here are examples of outgoing and\ - \ incoming ports for reference:" - , D.indent 4 $ D.vcat $ - [ D.fillSep [D.cyan "port","send",":","String -> Cmd msg"] - , D.fillSep [D.cyan "port","receive",":","(String -> msg) -> Sub msg"] - ] - , D.reflow $ - "The first line defines a `send` port so you can send strings out to JavaScript.\ - \ Maybe you send them on a WebSocket or put them into IndexedDB. The second line\ - \ defines a `receive` port so you can receive strings from JavaScript. Maybe you\ - \ get receive messages when new WebSocket messages come in or when an entry in\ - \ IndexedDB changes for some external reason." - ] - ) - - -portNote :: D.Doc -portNote = - D.stack - [ D.toSimpleNote $ - "Here are some example `port` declarations for reference:" - , D.indent 4 $ D.vcat $ - [ D.fillSep [D.cyan "port","send",":","String -> Cmd msg"] - , D.fillSep [D.cyan "port","receive",":","(String -> msg) -> Sub msg"] - ] - , D.reflow $ - "The first line defines a `send` port so you can send strings out to JavaScript.\ - \ Maybe you send them on a WebSocket or put them into IndexedDB. The second line\ - \ defines a `receive` port so you can receive strings from JavaScript. Maybe you\ - \ get receive messages when new WebSocket messages come in or when the IndexedDB\ - \ is changed for some external reason." - ] - - - --- DECL TYPE - - -toDeclTypeReport :: Code.Source -> DeclType -> Row -> Col -> Report.Report -toDeclTypeReport source declType startRow startCol = - case declType of - DT_Space space row col -> - toSpaceReport source space row col - - DT_Name row col -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - in - Report.Report "EXPECTING TYPE NAME" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I think I am parsing a type declaration, but I got stuck here:" - , - D.stack - [ D.fillSep $ - ["I","was","expecting","a","name","like",D.dullyellow "Status","or",D.dullyellow "Style" - ,"next.","Just","make","sure","it","is","a","name","that","starts","with","a","capital","letter!" - ] - , customTypeNote - ] - ) - - DT_Alias typeAlias row col -> - toTypeAliasReport source typeAlias row col - - DT_Union customType row col -> - toCustomTypeReport source customType row col - - DT_IndentName row col -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - in - Report.Report "EXPECTING TYPE NAME" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I think I am parsing a type declaration, but I got stuck here:" - , - D.stack - [ D.fillSep $ - ["I","was","expecting","a","name","like",D.dullyellow "Status","or",D.dullyellow "Style" - ,"next.","Just","make","sure","it","is","a","name","that","starts","with","a","capital","letter!" - ] - , customTypeNote - ] - ) - - -toTypeAliasReport :: Code.Source -> TypeAlias -> Row -> Col -> Report.Report -toTypeAliasReport source typeAlias startRow startCol = - case typeAlias of - AliasSpace space row col -> - toSpaceReport source space row col - - AliasName row col -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - in - Report.Report "EXPECTING TYPE ALIAS NAME" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I am partway through parsing a type alias, but I got stuck here:" - , - D.stack - [ D.fillSep $ - ["I","was","expecting","a","name","like",D.dullyellow "Person","or",D.dullyellow "Point" - ,"next.","Just","make","sure","it","is","a","name","that","starts","with","a","capital","letter!" - ] - , typeAliasNote - ] - ) - - AliasEquals row col -> - case Code.whatIsNext source row col of - Code.Keyword keyword -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toKeywordRegion row col keyword - in - Report.Report "RESERVED WORD" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I ran into a reserved word unexpectedly while parsing this type alias:" - , - D.stack - [ D.reflow $ - "It looks like you are trying use `" ++ keyword - ++ "` as a type variable, but it is a reserved word. Try using a different name?" - , typeAliasNote - ] - ) - - _ -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - in - Report.Report "PROBLEM IN TYPE ALIAS" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I am partway through parsing a type alias, but I got stuck here:" - , - D.stack - [ D.reflow $ - "I was expecting to see a type variable or an equals sign next." - , typeAliasNote - ] - ) - - AliasBody tipe row col -> - toTypeReport source TC_TypeAlias tipe row col - - AliasIndentEquals row col -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - in - Report.Report "UNFINISHED TYPE ALIAS" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I am partway through parsing a type alias, but I got stuck here:" - , - D.stack - [ D.reflow $ - "I was expecting to see a type variable or an equals sign next." - , typeAliasNote - ] - ) - - AliasIndentBody row col -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - in - Report.Report "UNFINISHED TYPE ALIAS" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I am partway through parsing a type alias, but I got stuck here:" - , - D.stack - [ D.fillSep $ - ["I","was","expecting","to","see","a","type","next.","Something","as","simple" - ,"as",D.dullyellow "Int","or",D.dullyellow "Float","would","work!" - ] - , typeAliasNote - ] - ) - - -typeAliasNote :: D.Doc -typeAliasNote = - D.stack - [ D.toSimpleNote $ - "Here is an example of a valid `type alias` for reference:" - , D.vcat $ - [ D.indent 4 $ D.fillSep [D.cyan "type",D.cyan "alias","Person","="] - , D.indent 6 $ D.vcat $ - ["{ name : String" - ,", age : Int" - ,", height : Float" - ,"}" - ] - ] - , D.reflow $ - "This would let us use `Person` as a shorthand for that record type. Using this\ - \ shorthand makes type annotations much easier to read, and makes changing code\ - \ easier if you decide later that there is more to a person than age and height!" - ] - - -toCustomTypeReport :: Code.Source -> CustomType -> Row -> Col -> Report.Report -toCustomTypeReport source customType startRow startCol = - case customType of - CT_Space space row col -> - toSpaceReport source space row col - - CT_Name row col -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - in - Report.Report "EXPECTING TYPE NAME" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I think I am parsing a type declaration, but I got stuck here:" - , - D.stack - [ D.fillSep $ - ["I","was","expecting","a","name","like",D.dullyellow "Status","or",D.dullyellow "Style" - ,"next.","Just","make","sure","it","is","a","name","that","starts","with","a","capital","letter!" - ] - , customTypeNote - ] - ) - - CT_Equals row col -> - case Code.whatIsNext source row col of - Code.Keyword keyword -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toKeywordRegion row col keyword - in - Report.Report "RESERVED WORD" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I ran into a reserved word unexpectedly while parsing this custom type:" - , - D.stack - [ D.reflow $ - "It looks like you are trying use `" ++ keyword - ++ "` as a type variable, but it is a reserved word. Try using a different name?" - , customTypeNote - ] - ) - - _ -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - in - Report.Report "PROBLEM IN CUSTOM TYPE" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I am partway through parsing a custom type, but I got stuck here:" - , - D.stack - [ D.reflow $ - "I was expecting to see a type variable or an equals sign next." - , customTypeNote - ] - ) - - CT_Bar row col -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - in - Report.Report "PROBLEM IN CUSTOM TYPE" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I am partway through parsing a custom type, but I got stuck here:" - , - D.stack - [ D.reflow $ - "I was expecting to see a vertical bar like | next." - , customTypeNote - ] - ) - - CT_Variant row col -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - in - Report.Report "PROBLEM IN CUSTOM TYPE" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I am partway through parsing a custom type, but I got stuck here:" - , - D.stack - [ D.fillSep $ - ["I","was","expecting","to","see","a","variant","name","next." - ,"Something","like",D.dullyellow "Success","or",D.dullyellow "Sandwich" <> "." - ,"Any","name","that","starts","with","a","capital","letter","really!" - ] - , customTypeNote - ] - ) - - CT_VariantArg tipe row col -> - toTypeReport source TC_CustomType tipe row col - - CT_IndentEquals row col -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - in - Report.Report "UNFINISHED CUSTOM TYPE" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I am partway through parsing a custom type, but I got stuck here:" - , - D.stack - [ D.reflow $ - "I was expecting to see a type variable or an equals sign next." - , customTypeNote - ] - ) - - CT_IndentBar row col -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - in - Report.Report "UNFINISHED CUSTOM TYPE" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I am partway through parsing a custom type, but I got stuck here:" - , - D.stack - [ D.reflow $ - "I was expecting to see a vertical bar like | next." - , customTypeNote - ] - ) - - CT_IndentAfterBar row col -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - in - Report.Report "UNFINISHED CUSTOM TYPE" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I am partway through parsing a custom type, but I got stuck here:" - , - D.stack - [ D.reflow $ - "I just saw a vertical bar, so I was expecting to see another variant defined next." - , customTypeNote - ] - ) - - CT_IndentAfterEquals row col -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - in - Report.Report "UNFINISHED CUSTOM TYPE" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I am partway through parsing a custom type, but I got stuck here:" - , - D.stack - [ D.reflow $ - "I just saw an equals sign, so I was expecting to see the first variant defined next." - , customTypeNote - ] - ) - - -customTypeNote :: D.Doc -customTypeNote = - D.stack - [ D.toSimpleNote $ - "Here is an example of a valid `type` declaration for reference:" - , D.vcat $ - [ D.indent 4 $ D.fillSep [D.cyan "type","Status"] - , D.indent 6 $ D.fillSep ["=","Failure"] - , D.indent 6 $ D.fillSep ["|","Waiting"] - , D.indent 6 $ D.fillSep ["|","Success","String"] - ] - , D.reflow $ - "This defines a new `Status` type with three variants. This could be useful if\ - \ we are waiting for an HTTP request. Maybe we start with `Waiting` and then\ - \ switch to `Failure` or `Success \"message from server\"` depending on how\ - \ things go. Notice that the Success variant has some associated data, allowing\ - \ us to store a String if the request goes well!" - ] - - - --- DECL DEF - - -toDeclDefReport :: Code.Source -> Name.Name -> DeclDef -> Row -> Col -> Report.Report -toDeclDefReport source name declDef startRow startCol = - case declDef of - DeclDefSpace space row col -> - toSpaceReport source space row col - - DeclDefEquals row col -> - case Code.whatIsNext source row col of - Code.Keyword keyword -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toKeywordRegion row col keyword - in - Report.Report "RESERVED WORD" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.fillSep - ["The","name" - ,"`" <> D.cyan (D.fromChars keyword) <> "`" - ,"is","reserved","in","Elm,","so","it","cannot" - ,"be","used","as","an","argument","here:" - ] - , - D.stack - [ D.reflow $ - "Try renaming it to something else." - , case keyword of - "as" -> - D.toFancyNote - ["This","keyword","is","reserved","for","pattern","matches","like" - ,"((x,y)",D.cyan "as","point)","where","you","want","to","name","a","tuple","and" - ,"the","values","it","contains." - ] - - _ -> - D.toSimpleNote $ - "The `" ++ keyword ++ "` keyword has a special meaning in Elm, so it can only be used in certain situations." - ] - ) - - Code.Operator "->" -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toWiderRegion row col 2 - in - Report.Report "MISSING COLON?" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I was not expecting to see an arrow here:" - , - D.stack - [ D.fillSep - ["This","usually","means","a",D.green ":","is","missing","a","bit","earlier","in" - ,"a","type","annotation.","It","could","be","something","else","though,","so" - ,"here","is","a","valid","definition","for","reference:" - ] - , D.indent 4 $ D.vcat $ - [ "greet : String -> String" - , "greet name =" - , " " <> D.dullyellow "\"Hello \"" <> " ++ name ++ " <> D.dullyellow "\"!\"" - ] - , D.reflow $ - "Try to use that format with your `" ++ Name.toChars name ++ "` definition!" - ] - ) - - Code.Operator op -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toKeywordRegion row col op - in - Report.Report "UNEXPECTED SYMBOL" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I was not expecting to see this symbol here:" - , - D.stack - [ D.reflow $ - "I am not sure what is going wrong exactly, so here is a valid\ - \ definition (with an optional type annotation) for reference:" - , D.indent 4 $ D.vcat $ - [ "greet : String -> String" - , "greet name =" - , " " <> D.dullyellow "\"Hello \"" <> " ++ name ++ " <> D.dullyellow "\"!\"" - ] - , D.reflow $ - "Try to use that format with your `" ++ Name.toChars name ++ "` definition!" - ] - ) - - _ -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - in - Report.Report "PROBLEM IN DEFINITION" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I got stuck while parsing the `" ++ Name.toChars name ++ "` definition:" - , - D.stack - [ D.reflow $ - "I am not sure what is going wrong exactly, so here is a valid\ - \ definition (with an optional type annotation) for reference:" - , D.indent 4 $ D.vcat $ - [ "greet : String -> String" - , "greet name =" - , " " <> D.dullyellow "\"Hello \"" <> " ++ name ++ " <> D.dullyellow "\"!\"" - ] - , D.reflow $ - "Try to use that format!" - ] - ) - - DeclDefType tipe row col -> - toTypeReport source (TC_Annotation name) tipe row col - - DeclDefArg pattern row col -> - toPatternReport source PArg pattern row col - - DeclDefBody expr row col -> - toExprReport source (InDef name startRow startCol) expr row col - - DeclDefNameRepeat row col -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - in - Report.Report "EXPECTING DEFINITION" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I just saw the type annotation for `" ++ Name.toChars name - ++ "` so I was expecting to see its definition here:" - , - D.stack - [ D.reflow $ - "Type annotations always appear directly above the relevant\ - \ definition, without anything else in between. (Not even doc comments!)" - , declDefNote - ] - ) - - DeclDefNameMatch defName row col -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - in - Report.Report "NAME MISMATCH" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I just saw a type annotation for `" ++ Name.toChars name ++ "`, but it is followed by a definition for `" ++ Name.toChars defName ++ "`:" - , - D.stack - [ D.reflow $ - "These names do not match! Is there a typo?" - , D.indent 4 $ D.fillSep $ - [D.dullyellow (D.fromName defName),"->",D.green (D.fromName name)] - ] - ) - - DeclDefIndentType row col -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - in - Report.Report "UNFINISHED DEFINITION" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I got stuck while parsing the `" ++ Name.toChars name ++ "` type annotation:" - , - D.stack - [ D.reflow $ - "I just saw a colon, so I am expecting to see a type next." - , declDefNote - ] - ) - - DeclDefIndentEquals row col -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - in - Report.Report "UNFINISHED DEFINITION" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I got stuck while parsing the `" ++ Name.toChars name ++ "` definition:" - , - D.stack - [ D.reflow $ - "I was expecting to see an argument or an equals sign next." - , declDefNote - ] - ) - - DeclDefIndentBody row col -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - in - Report.Report "UNFINISHED DEFINITION" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I got stuck while parsing the `" ++ Name.toChars name ++ "` definition:" - , - D.stack - [ D.reflow $ - "I was expecting to see an expression next. What is it equal to?" - , declDefNote - ] - ) - - -declDefNote :: D.Doc -declDefNote = - D.stack - [ D.reflow $ - "Here is a valid definition (with a type annotation) for reference:" - , D.indent 4 $ D.vcat $ - [ "greet : String -> String" - , "greet name =" - , " " <> D.dullyellow "\"Hello \"" <> " ++ name ++ " <> D.dullyellow "\"!\"" - ] - , D.reflow $ - "The top line (called a \"type annotation\") is optional. You can leave it off\ - \ if you want. As you get more comfortable with Elm and as your project grows,\ - \ it becomes more and more valuable to add them though! They work great as\ - \ compiler-verified documentation, and they often improve error messages!" - ] - - - --- CONTEXT - - -data Context - = InNode Node Row Col Context - | InDef Name.Name Row Col - | InDestruct Row Col - - -data Node - = NRecord - | NParens - | NList - | NFunc - | NCond - | NThen - | NElse - | NCase - | NBranch - deriving (Eq) - - -getDefName :: Context -> Maybe Name.Name -getDefName context = - case context of - InDestruct _ _ -> Nothing - InDef name _ _ -> Just name - InNode _ _ _ c -> getDefName c - - -isWithin :: Node -> Context -> Bool -isWithin desiredNode context = - case context of - InDestruct _ _ -> False - InDef _ _ _ -> False - InNode actualNode _ _ _ -> desiredNode == actualNode - - - --- EXPR REPORTS - - -toExprReport :: Code.Source -> Context -> Expr -> Row -> Col -> Report.Report -toExprReport source context expr startRow startCol = - case expr of - Let let_ row col -> - toLetReport source context let_ row col - - Case case_ row col -> - toCaseReport source context case_ row col - - If if_ row col -> - toIfReport source context if_ row col - - List list row col -> - toListReport source context list row col - - Record record row col -> - toRecordReport source context record row col - - Tuple tuple row col -> - toTupleReport source context tuple row col - - Func func row col -> - toFuncReport source context func row col - - Dot row col -> - let region = toRegion row col in - Report.Report "EXPECTING RECORD ACCESSOR" region [] $ - Code.toSnippet source region Nothing - ( - D.reflow $ - "I was expecting to see a record accessor here:" - , - D.fillSep - ["Something","like",D.dullyellow".name","or",D.dullyellow".price" - ,"that","accesses","a","value","from","a","record." - ] - ) - - Access row col -> - let region = toRegion row col in - Report.Report "EXPECTING RECORD ACCESSOR" region [] $ - Code.toSnippet source region Nothing - ( - D.reflow $ - "I am trying to parse a record accessor here:" - , - D.stack - [ - D.fillSep - ["Something","like",D.dullyellow".name","or",D.dullyellow".price" - ,"that","accesses","a","value","from","a","record." - ] - , - D.toSimpleNote $ - "Record field names must start with a lower case letter!" - ] - ) - - OperatorRight op row col -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - isMath = elem op ["-","+","*","/","^"] - in - Report.Report "MISSING EXPRESSION" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I just saw a " ++ Name.toChars op ++ " " - ++ (if isMath then "sign" else "operator") - ++ ", so I am getting stuck here:" - , - if isMath then - D.fillSep - ["I","was","expecting","to","see","an","expression","next." - ,"Something","like",D.dullyellow "42","or",D.dullyellow "1000" - ,"that","makes","sense","with","a",D.fromName op,"sign." - ] - else if op == "&&" || op == "||" then - D.fillSep - ["I","was","expecting","to","see","an","expression","next." - ,"Something","like",D.dullyellow "True","or",D.dullyellow "False" - ,"that","makes","sense","with","boolean","logic." - ] - else if op == "|>" then - D.reflow $ - "I was expecting to see a function next." - else if op == "<|" then - D.reflow $ - "I was expecting to see an argument next." - else - D.reflow $ - "I was expecting to see an expression next." - ) - - OperatorReserved operator row col -> - toOperatorReport source context operator row col - - Start row col -> - let - (contextRow, contextCol, aThing) = - case context of - InDestruct r c -> (r, c, "a definition") - InDef name r c -> (r, c, "the `" ++ Name.toChars name ++ "` definition") - InNode NRecord r c _ -> (r, c, "a record") - InNode NParens r c _ -> (r, c, "some parentheses") - InNode NList r c _ -> (r, c, "a list") - InNode NFunc r c _ -> (r, c, "an anonymous function") - InNode NCond r c _ -> (r, c, "an `if` expression") - InNode NThen r c _ -> (r, c, "an `if` expression") - InNode NElse r c _ -> (r, c, "an `if` expression") - InNode NCase r c _ -> (r, c, "a `case` expression") - InNode NBranch r c _ -> (r, c, "a `case` expression") - - surroundings = A.Region (A.Position contextRow contextCol) (A.Position row col) - region = toRegion row col - in - Report.Report "MISSING EXPRESSION" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I am partway through parsing " ++ aThing ++ ", but I got stuck here:" - , - D.stack - [ D.fillSep $ - ["I","was","expecting","to","see","an","expression","like" - ,D.dullyellow "42","or",D.dullyellow"\"hello\"" <> "." - ,"Once","there","is","something","there,","I","can","probably" - ,"give","a","more","specific","hint!" - ] - , D.toSimpleNote $ - "This can also happen if run into reserved words like `let` or `as` unexpectedly.\ - \ Or if I run into operators in unexpected spots. Point is, there are a\ - \ couple ways I can get confused and give sort of weird advice!" - ] - ) - - Char char row col -> - toCharReport source char row col - - String string row col -> - toStringReport source string row col - - Number number row col -> - toNumberReport source number row col - - Space space row col -> - toSpaceReport source space row col - - EndlessShader row col -> - let - region = toWiderRegion row col 6 - in - Report.Report "ENDLESS SHADER" region [] $ - Code.toSnippet source region Nothing - ( - D.reflow "I cannot find the end of this shader:" - , - D.reflow "Add a |] somewhere after this to end the shader." - ) - - ShaderProblem problem row col -> - let - region = toRegion row col - in - Report.Report "SHADER PROBLEM" region [] $ - Code.toSnippet source region Nothing - ( - D.reflow $ - "I ran into a problem while parsing this GLSL block." - , - D.stack - [ D.reflow $ - "I use a 3rd party GLSL parser for now, and I did my best to extract their error message:" - , D.indent 4 $ D.vcat $ - map D.fromChars (filter (/="") (lines problem)) - ] - ) - - IndentOperatorRight op row col -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - in - Report.Report "MISSING EXPRESSION" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I was expecting to see an expression after this " ++ Name.toChars op ++ " operator:" - , - D.stack - [ - D.fillSep $ - ["You","can","just","put","anything","for","now,","like" - ,D.dullyellow "42","or",D.dullyellow"\"hello\"" <> "." - ,"Once","there","is","something","there,","I","can","probably" - ,"give","a","more","specific","hint!" - ] - , - D.toSimpleNote $ - "I may be getting confused by your indentation? The easiest way to make sure\ - \ this is not an indentation problem is to put the expression on the right of\ - \ the " ++ Name.toChars op ++ " operator on the same line." - ] - ) - - - --- CHAR - - -toCharReport :: Code.Source -> Char -> Row -> Col -> Report.Report -toCharReport source char row col = - case char of - CharEndless -> - let - region = toRegion row col - in - Report.Report "MISSING SINGLE QUOTE" region [] $ - Code.toSnippet source region Nothing - ( - D.reflow $ - "I thought I was parsing a character, but I got to the end of\ - \ the line without seeing the closing single quote:" - , - D.reflow $ - "Add a closing single quote here!" - ) - - CharEscape escape -> - toEscapeReport source escape row col - - CharNotString width -> - let - region = toWiderRegion row col width - in - Report.Report "NEEDS DOUBLE QUOTES" region [] $ - Code.toSnippet source region Nothing - ( - "The following string uses single quotes:" - , - D.stack - [ "Please switch to double quotes instead:" - , D.indent 4 $ - D.dullyellow "'this'" <> " => " <> D.green "\"this\"" - , D.toSimpleNote $ - "Elm uses double quotes for strings like \"hello\", whereas it uses single\ - \ quotes for individual characters like 'a' and 'ø'. This distinction helps with\ - \ code like (String.any (\\c -> c == 'X') \"90210\") where you are inspecting\ - \ individual characters." - ] - ) - - - --- STRING - - -toStringReport :: Code.Source -> String -> Row -> Col -> Report.Report -toStringReport source string row col = - case string of - StringEndless_Single -> - let - region = toRegion row col - in - Report.Report "ENDLESS STRING" region [] $ - Code.toSnippet source region Nothing - ( - D.reflow $ - "I got to the end of the line without seeing the closing double quote:" - , - D.stack - [ D.fillSep $ - ["Strings","look","like",D.green "\"this\"","with","double" - ,"quotes","on","each","end.","Is","the","closing","double" - ,"quote","missing","in","your","code?" - ] - , D.toSimpleNote $ - "For a string that spans multiple lines, you can use the multi-line string\ - \ syntax like this:" - , D.dullyellow $ D.indent 4 $ D.vcat $ - [ "\"\"\"" - , "# Multi-line Strings" - , "" - , "- start with triple double quotes" - , "- write whatever you want" - , "- no need to escape newlines or double quotes" - , "- end with triple double quotes" - , "\"\"\"" - ] - ] - ) - - StringEndless_Multi -> - let - region = toWiderRegion row col 3 - in - Report.Report "ENDLESS STRING" region [] $ - Code.toSnippet source region Nothing - ( - D.reflow $ - "I cannot find the end of this multi-line string:" - , - D.stack - [ D.reflow "Add a \"\"\" somewhere after this to end the string." - , D.toSimpleNote $ - "Here is a valid multi-line string for reference:" - , D.dullyellow $ D.indent 4 $ D.vcat $ - [ "\"\"\"" - , "# Multi-line Strings" - , "" - , "- start with triple double quotes" - , "- write whatever you want" - , "- no need to escape newlines or double quotes" - , "- end with triple double quotes" - , "\"\"\"" - ] - ] - ) - - StringEscape escape -> - toEscapeReport source escape row col - - - --- ESCAPES - - -toEscapeReport :: Code.Source -> Escape -> Row -> Col -> Report.Report -toEscapeReport source escape row col = - case escape of - EscapeUnknown -> - let - region = toWiderRegion row col 2 - in - Report.Report "UNKNOWN ESCAPE" region [] $ - Code.toSnippet source region Nothing - ( - D.reflow $ - "Backslashes always start escaped characters, but I do not recognize this one:" - , - D.stack - [ D.reflow $ - "Valid escape characters include:" - , D.dullyellow $ D.indent 4 $ D.vcat $ - [ "\\n" - , "\\r" - , "\\t" - , "\\\"" - , "\\\'" - , "\\\\" - , "\\u{003D}" - ] - , D.reflow $ - "Do you want one of those instead? Maybe you need \\\\ to escape a backslash?" - , D.toSimpleNote $ - "The last style lets encode ANY character by its Unicode code\ - \ point. That means \\u{0009} and \\t are the same. You can use\ - \ that style for anything not covered by the other six escapes!" - ] - ) - - BadUnicodeFormat width -> - let - region = toWiderRegion row col width - in - Report.Report "BAD UNICODE ESCAPE" region [] $ - Code.toSnippet source region Nothing - ( - D.reflow $ - "I ran into an invalid Unicode escape:" - , - D.stack - [ D.reflow $ - "Here are some examples of valid Unicode escapes:" - , D.dullyellow $ D.indent 4 $ D.vcat $ - [ "\\u{0041}" - , "\\u{03BB}" - , "\\u{6728}" - , "\\u{1F60A}" - ] - , D.reflow $ - "Notice that the code point is always surrounded by curly braces.\ - \ Maybe you are missing the opening or closing curly brace?" - ] - ) - BadUnicodeCode width -> - let - region = toWiderRegion row col width - in - Report.Report "BAD UNICODE ESCAPE" region [] $ - Code.toSnippet source region Nothing - ( - D.reflow $ - "This is not a valid code point:" - , - D.reflow $ - "The valid code points are between 0 and 10FFFF inclusive." - ) - - BadUnicodeLength width numDigits badCode -> - let - region = toWiderRegion row col width - in - Report.Report "BAD UNICODE ESCAPE" region [] $ - Code.toSnippet source region Nothing $ - if numDigits < 4 then - ( - D.reflow $ - "Every code point needs at least four digits:" - , - let - goodCode = replicate (4 - numDigits) '0' ++ map Char.toUpper (showHex badCode "") - suggestion = "\\u{" <> D.fromChars goodCode <> "}" - in - D.fillSep ["Try",D.green suggestion,"instead?"] - ) - - else - ( - D.reflow $ - "This code point has too many digits:" - , - D.fillSep $ - ["Valid","code","points","are","between" - ,D.green "\\u{0000}","and",D.green "\\u{10FFFF}" <> "," - ,"so","try","trimming","any","leading","zeros","until" - ,"you","have","between","four","and","six","digits." - ] - ) - - - --- NUMBERS - - -toNumberReport :: Code.Source -> Number -> Row -> Col -> Report.Report -toNumberReport source number row col = - let - region = toRegion row col - in - case number of - NumberEnd -> - Report.Report "WEIRD NUMBER" region [] $ - Code.toSnippet source region Nothing - ( - D.reflow $ - "I thought I was reading a number, but I ran into some weird stuff here:" - , - D.stack - [ D.reflow $ - "I recognize numbers in the following formats:" - , D.indent 4 $ D.vcat [ "42", "3.14", "6.022e23", "0x002B" ] - , D.reflow $ - "So is there a way to write it like one of those?" - ] - ) - - NumberDot int -> - Report.Report "WEIRD NUMBER" region [] $ - Code.toSnippet source region Nothing - ( - D.reflow $ - "Numbers cannot end with a dot like this:" - , - D.fillSep - ["Switching","to",D.green (D.fromChars (show int)) - ,"or",D.green (D.fromChars (show int ++ ".0")) - ,"will","work","though!" - ] - ) - - NumberHexDigit -> - Report.Report "WEIRD HEXIDECIMAL" region [] $ - Code.toSnippet source region Nothing - ( - D.reflow $ - "I thought I was reading a hexidecimal number until I got here:" - , - D.stack - [ D.reflow $ - "Valid hexidecimal digits include 0123456789abcdefABCDEF, so I can\ - \ only recognize things like this:" - , D.indent 4 $ D.vcat [ "0x2B", "0x002B", "0x00ffb3" ] - ] - ) - - NumberNoLeadingZero -> - Report.Report "LEADING ZEROS" region [] $ - Code.toSnippet source region Nothing - ( - D.reflow $ - "I do not accept numbers with leading zeros:" - , - D.stack - [ D.reflow $ - "Just delete the leading zeros and it should work!" - , D.toSimpleNote $ - "Some languages let you to specify octal numbers by adding a leading zero.\ - \ So in C, writing 0111 is the same as writing 73. Some people are used to\ - \ that, but others probably want it to equal 111. Either path is going to\ - \ surprise people from certain backgrounds, so Elm tries to avoid this whole\ - \ situation." - ] - ) - - - --- OPERATORS - - -toOperatorReport :: Code.Source -> Context -> BadOperator -> Row -> Col -> Report.Report -toOperatorReport source context operator row col = - case operator of - BadDot -> - let - region = toRegion row col - in - Report.Report "UNEXPECTED SYMBOL" region [] $ - Code.toSnippet source region Nothing - ( - "I was not expecting this dot:" - , - D.reflow $ - "Dots are for record access and decimal points, so\ - \ they cannot float around on their own. Maybe\ - \ there is some extra whitespace?" - ) - - BadPipe -> - let - region = toRegion row col - in - Report.Report "UNEXPECTED SYMBOL" region [] $ - Code.toSnippet source region Nothing - ( - D.reflow $ - "I was not expecting this vertical bar:" - , - D.reflow $ - "Vertical bars should only appear in custom type declarations. Maybe you want || instead?" - ) - - BadArrow -> - let - region = toWiderRegion row col 2 - in - Report.Report "UNEXPECTED ARROW" region [] $ - Code.toSnippet source region Nothing $ - if isWithin NCase context then - ( - D.reflow $ - "I am parsing a `case` expression right now, but this arrow is confusing me:" - , - D.stack - [ D.reflow "Maybe the `of` keyword is missing on a previous line?" - , noteForCaseError - ] - ) - - else if isWithin NBranch context then - ( - D.reflow $ - "I am parsing a `case` expression right now, but this arrow is confusing me:" - , - D.stack - [ D.reflow $ - "It makes sense to see arrows around here, so I suspect it is something earlier. Maybe this pattern is indented a bit farther than the previous patterns?" - , noteForCaseIndentError - ] - ) - - else - ( - D.reflow $ - "I was partway through parsing an expression when I got stuck on this arrow:" - , - D.stack - [ "Arrows should only appear in `case` expressions and anonymous functions.\n\ - \Maybe it was supposed to be a > sign instead?" - , D.toSimpleNote $ - "The syntax for anonymous functions is (\\x -> x + 1) so the arguments all appear\ - \ after the backslash and before the arrow. Maybe a backslash is missing earlier?" - ] - ) - - BadEquals -> - let - region = toRegion row col - in - Report.Report "UNEXPECTED EQUALS" region [] $ - Code.toSnippet source region Nothing - ( - D.reflow $ - "I was not expecting to see this equals sign:" - , - D.stack - [ - D.reflow "Maybe you want == instead? To check if two values are equal?" - , - D.toSimpleNote $ - if isWithin NRecord context then - "Records look like { x = 3, y = 4 } with the equals sign right\ - \ after the field name. So maybe you forgot a comma?" - else - case getDefName context of - Nothing -> - "I may be getting confused by your indentation. I need all definitions to be indented\ - \ exactly the same amount, so if this is meant to be a new definition, it may have too\ - \ many spaces in front of it." - - Just name -> - "I may be getting confused by your indentation. I think I am still parsing the `" - ++ Name.toChars name ++ "` definition. Is this supposed to be part of a definition\ - \ after that? If so, the problem may be a bit before the equals sign. I need all\ - \ definitions to be indented exactly the same amount, so the problem may be that\ - \ this new definition has too many spaces in front of it." - ] - ) - - BadHasType -> - let - region = toRegion row col - in - Report.Report "UNEXPECTED SYMBOL" region [] $ - Code.toSnippet source region Nothing $ - ( - D.reflow $ - "I was not expecting to run into the \"has type\" symbol here:" - , - case getDefName context of - Nothing -> - D.fillSep - ["Maybe","you","want",D.green "::","instead?" - ,"To","put","something","on","the","front","of","a","list?" - ] - - Just name -> - D.stack - [ - D.fillSep - ["Maybe","you","want",D.green "::","instead?" - ,"To","put","something","on","the","front","of","a","list?" - ] - , D.toSimpleNote $ - "The single colon is reserved for type annotations and record types, but I think\ - \ I am parsing the definition of `" ++ Name.toChars name ++ "` right now." - , - D.toSimpleNote $ - "I may be getting confused by your indentation. Is this supposed to be part of\ - \ a type annotation AFTER the `" ++ Name.toChars name ++ "` definition? If so,\ - \ the problem may be a bit before the \"has type\" symbol. I need all definitions to\ - \ be exactly aligned (with exactly the same indentation) so the problem may be that\ - \ this new definition is indented a bit too much." - ] - ) - - - --- CASE - - -toLetReport :: Code.Source -> Context -> Let -> Row -> Col -> Report.Report -toLetReport source context let_ startRow startCol = - case let_ of - LetSpace space row col -> - toSpaceReport source space row col - - LetIn row col -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - in - Report.Report "LET PROBLEM" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I was partway through parsing a `let` expression, but I got stuck here:" - , - D.stack - [ D.fillSep $ - ["Based","on","the","indentation,","I","was","expecting","to","see","the",D.cyan "in" - ,"keyword","next.","Is","there","a","typo?" - ] - , D.toSimpleNote $ - "This can also happen if you are trying to define another value within the `let` but\ - \ it is not indented enough. Make sure each definition has exactly the same amount of\ - \ spaces before it. They should line up exactly!" - ] - ) - - LetDefAlignment _ row col -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - in - Report.Report "LET PROBLEM" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I was partway through parsing a `let` expression, but I got stuck here:" - , - D.stack - [ D.fillSep $ - ["Based","on","the","indentation,","I","was","expecting","to","see","the",D.cyan "in" - ,"keyword","next.","Is","there","a","typo?" - ] - , D.toSimpleNote $ - "This can also happen if you are trying to define another value within the `let` but\ - \ it is not indented enough. Make sure each definition has exactly the same amount of\ - \ spaces before it. They should line up exactly!" - ] - ) - - LetDefName row col -> - case Code.whatIsNext source row col of - Code.Keyword keyword -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toKeywordRegion row col keyword - in - Report.Report "RESERVED WORD" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I was partway through parsing a `let` expression, but I got stuck here:" - , - D.reflow $ - "It looks like you are trying to use `" ++ keyword ++ "` as a variable name, but\ - \ it is a reserved word! Try using a different name instead." - ) - - _ -> - toUnfinishLetReport source row col startRow startCol $ - D.reflow $ - "I was expecting the name of a definition next." - - LetDef name def row col -> - toLetDefReport source name def row col - - LetDestruct destruct row col -> - toLetDestructReport source destruct row col - - LetBody expr row col -> - toExprReport source context expr row col - - LetIndentDef row col -> - toUnfinishLetReport source row col startRow startCol $ - D.reflow $ - "I was expecting a value to be defined here." - - LetIndentIn row col -> - toUnfinishLetReport source row col startRow startCol $ - D.fillSep $ - ["I","was","expecting","to","see","the",D.cyan "in","keyword","next." - ,"Or","maybe","more","of","that","expression?" - ] - - LetIndentBody row col -> - toUnfinishLetReport source row col startRow startCol $ - D.reflow $ - "I was expecting an expression next. Tell me what should happen with the value you just defined!" - - -toUnfinishLetReport :: Code.Source -> Row -> Col -> Row -> Col -> D.Doc -> Report.Report -toUnfinishLetReport source row col startRow startCol message = - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - in - Report.Report "UNFINISHED LET" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I was partway through parsing a `let` expression, but I got stuck here:" - , - D.stack - [ message - , D.toSimpleNote $ - "Here is an example with a valid `let` expression for reference:" - , D.indent 4 $ D.vcat $ - [ D.indent 0 $ D.fillSep ["viewPerson","person","="] - , D.indent 2 $ D.fillSep [D.cyan "let"] - , D.indent 4 $ D.fillSep ["fullName","="] - , D.indent 6 $ D.fillSep ["person.firstName","++",D.dullyellow "\" \"","++","person.lastName"] - , D.indent 2 $ D.fillSep [D.cyan "in"] - , D.indent 2 $ D.fillSep ["div","[]","[","text","fullName","]"] - ] - , D.reflow $ - "Here we defined a `viewPerson` function that turns a person into some HTML. We use\ - \ a `let` expression to define the `fullName` we want to show. Notice the indentation! The\ - \ `fullName` is indented more than the `let` keyword, and the actual value of `fullName` is\ - \ indented a bit more than that. That is important!" - ] - ) - - -toLetDefReport :: Code.Source -> Name.Name -> Def -> Row -> Col -> Report.Report -toLetDefReport source name def startRow startCol = - case def of - DefSpace space row col -> - toSpaceReport source space row col - - DefType tipe row col -> - toTypeReport source (TC_Annotation name) tipe row col - - DefNameRepeat row col -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - in - Report.Report "EXPECTING DEFINITION" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I just saw the type annotation for `" ++ Name.toChars name - ++ "` so I was expecting to see its definition here:" - , - D.stack - [ D.reflow $ - "Type annotations always appear directly above the relevant\ - \ definition, without anything else in between." - , defNote - ] - ) - - DefNameMatch defName row col -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - in - Report.Report "NAME MISMATCH" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I just saw a type annotation for `" ++ Name.toChars name ++ "`, but it is followed by a definition for `" ++ Name.toChars defName ++ "`:" - , - D.stack - [ D.reflow $ - "These names do not match! Is there a typo?" - , D.indent 4 $ D.fillSep $ - [D.dullyellow (D.fromName defName),"->",D.green (D.fromName name)] - ] - ) - - DefArg pattern row col -> - toPatternReport source PArg pattern row col - - DefEquals row col -> - case Code.whatIsNext source row col of - Code.Keyword keyword -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toKeywordRegion row col keyword - in - Report.Report "RESERVED WORD" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.fillSep - ["The","name" - ,"`" <> D.cyan (D.fromChars keyword) <> "`" - ,"is","reserved","in","Elm,","so","it","cannot" - ,"be","used","as","an","argument","here:" - ] - , - D.stack - [ D.reflow $ - "Try renaming it to something else." - , case keyword of - "as" -> - D.toFancyNote - ["This","keyword","is","reserved","for","pattern","matches","like" - ,"((x,y)",D.cyan "as","point)","where","you","want","to","name","a","tuple","and" - ,"the","values","it","contains." - ] - - _ -> - D.toSimpleNote $ - "The `" ++ keyword ++ "` keyword has a special meaning in Elm, so it can only be used in certain situations." - ] - ) - - Code.Operator "->" -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toWiderRegion row col 2 - in - Report.Report "MISSING COLON?" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I was not expecting to see an arrow here:" - , - D.stack - [ D.fillSep - ["This","usually","means","a",D.green ":","is","missing","a","bit","earlier","in" - ,"a","type","annotation.","It","could","be","something","else","though,","so" - ,"here","is","a","valid","definition","for","reference:" - ] - , D.indent 4 $ D.vcat $ - [ "greet : String -> String" - , "greet name =" - , " " <> D.dullyellow "\"Hello \"" <> " ++ name ++ " <> D.dullyellow "\"!\"" - ] - , D.reflow $ - "Try to use that format with your `" ++ Name.toChars name ++ "` definition!" - ] - ) - - Code.Operator op -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toKeywordRegion row col op - in - Report.Report "UNEXPECTED SYMBOL" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I was not expecting to see this symbol here:" - , - D.stack - [ D.reflow $ - "I am not sure what is going wrong exactly, so here is a valid\ - \ definition (with an optional type annotation) for reference:" - , D.indent 4 $ D.vcat $ - [ "greet : String -> String" - , "greet name =" - , " " <> D.dullyellow "\"Hello \"" <> " ++ name ++ " <> D.dullyellow "\"!\"" - ] - , D.reflow $ - "Try to use that format with your `" ++ Name.toChars name ++ "` definition!" - ] - ) - - _ -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - in - Report.Report "PROBLEM IN DEFINITION" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I got stuck while parsing the `" ++ Name.toChars name ++ "` definition:" - , - D.stack - [ D.reflow $ - "I am not sure what is going wrong exactly, so here is a valid\ - \ definition (with an optional type annotation) for reference:" - , D.indent 4 $ D.vcat $ - [ "greet : String -> String" - , "greet name =" - , " " <> D.dullyellow "\"Hello \"" <> " ++ name ++ " <> D.dullyellow "\"!\"" - ] - , D.reflow $ - "Try to use that format!" - ] - ) - - DefBody expr row col -> - toExprReport source (InDef name startRow startCol) expr row col - - DefIndentEquals row col -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - in - Report.Report "UNFINISHED DEFINITION" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I got stuck while parsing the `" ++ Name.toChars name ++ "` definition:" - , - D.stack - [ D.reflow $ - "I was expecting to see an argument or an equals sign next." - , defNote - ] - ) - - DefIndentType row col -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - in - Report.Report "UNFINISHED DEFINITION" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I got stuck while parsing the `" ++ Name.toChars name ++ "` type annotation:" - , - D.stack - [ D.reflow $ - "I just saw a colon, so I am expecting to see a type next." - , defNote - ] - ) - - DefIndentBody row col -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - in - Report.Report "UNFINISHED DEFINITION" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I got stuck while parsing the `" ++ Name.toChars name ++ "` definition:" - , - D.stack - [ D.reflow $ - "I was expecting to see an expression next. What is it equal to?" - , declDefNote - ] - ) - - DefAlignment indent row col -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - offset = indent - col - in - Report.Report "PROBLEM IN DEFINITION" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I got stuck while parsing the `" ++ Name.toChars name ++ "` definition:" - , - D.reflow $ - "I just saw a type annotation indented " ++ show indent ++ " spaces, so I was\ - \ expecting to see the corresponding definition next with the exact same amount\ - \ of indentation. It looks like this line needs " - ++ show offset ++ " more " ++ (if offset == 1 then "space" else "spaces") ++ "?" - ) - - - -defNote :: D.Doc -defNote = - D.stack - [ D.reflow $ - "Here is a valid definition (with a type annotation) for reference:" - , D.indent 4 $ D.vcat $ - [ "greet : String -> String" - , "greet name =" - , " " <> D.dullyellow "\"Hello \"" <> " ++ name ++ " <> D.dullyellow "\"!\"" - ] - , D.reflow $ - "The top line (called a \"type annotation\") is optional. You can leave it off\ - \ if you want. As you get more comfortable with Elm and as your project grows,\ - \ it becomes more and more valuable to add them though! They work great as\ - \ compiler-verified documentation, and they often improve error messages!" - ] - - -toLetDestructReport :: Code.Source -> Destruct -> Row -> Col -> Report.Report -toLetDestructReport source destruct startRow startCol = - case destruct of - DestructSpace space row col -> - toSpaceReport source space row col - - DestructPattern pattern row col -> - toPatternReport source PLet pattern row col - - DestructEquals row col -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - in - Report.Report "PROBLEM IN DEFINITION" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I got stuck trying to parse this definition:" - , - case Code.whatIsNext source row col of - Code.Operator ":" -> - D.stack - [ D.reflow $ - "I was expecting to see an equals sign next, followed by an expression\ - \ telling me what to compute." - , D.toSimpleNote $ - "It looks like you may be trying to write a type annotation? It is not\ - \ possible to add type annotations on destructuring definitions like this.\ - \ You can assign a name to the overall structure, put a type annotation on\ - \ that, and then destructure separately though." - ] - - _ -> - D.reflow $ - "I was expecting to see an equals sign next, followed by an expression\ - \ telling me what to compute." - ) - - DestructBody expr row col -> - toExprReport source (InDestruct startRow startCol) expr row col - - DestructIndentEquals row col -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - in - Report.Report "UNFINISHED DEFINITION" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I got stuck trying to parse this definition:" - , - D.reflow $ - "I was expecting to see an equals sign next, followed by an expression\ - \ telling me what to compute." - ) - - DestructIndentBody row col -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - in - Report.Report "UNFINISHED DEFINITION" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I got stuck while parsing this definition:" - , - D.reflow $ - "I was expecting to see an expression next. What is it equal to?" - ) - - - --- CASE - - -toCaseReport :: Code.Source -> Context -> Case -> Row -> Col -> Report.Report -toCaseReport source context case_ startRow startCol = - case case_ of - CaseSpace space row col -> - toSpaceReport source space row col - - CaseOf row col -> - toUnfinishCaseReport source row col startRow startCol $ - D.fillSep ["I","was","expecting","to","see","the",D.dullyellow "of","keyword","next."] - - CasePattern pattern row col -> - toPatternReport source PCase pattern row col - - CaseArrow row col -> - case Code.whatIsNext source row col of - Code.Keyword keyword -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toKeywordRegion row col keyword - in - Report.Report "RESERVED WORD" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I am partway through parsing a `case` expression, but I got stuck here:" - , - D.reflow $ - "It looks like you are trying to use `" ++ keyword ++ "` in one of your\ - \ patterns, but it is a reserved word. Try using a different name?" - ) - - Code.Operator ":" -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - in - Report.Report "UNEXPECTED OPERATOR" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I am partway through parsing a `case` expression, but I got stuck here:" - , - D.fillSep $ - ["I","am","seeing",D.dullyellow ":","but","maybe","you","want",D.green "::","instead?" - ,"For","pattern","matching","on","lists?" - ] - ) - - Code.Operator "=" -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - in - Report.Report "UNEXPECTED OPERATOR" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I am partway through parsing a `case` expression, but I got stuck here:" - , - D.fillSep $ - ["I","am","seeing",D.dullyellow "=","but","maybe","you","want",D.green "->","instead?" - ] - ) - - _ -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - in - Report.Report "MISSING ARROW" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I am partway through parsing a `case` expression, but I got stuck here:" - , - D.stack - [ D.reflow "I was expecting to see an arrow next." - , noteForCaseIndentError - ] - ) - - CaseExpr expr row col -> - toExprReport source (InNode NCase startRow startCol context) expr row col - - CaseBranch expr row col -> - toExprReport source (InNode NBranch startRow startCol context) expr row col - - CaseIndentOf row col -> - toUnfinishCaseReport source row col startRow startCol $ - D.fillSep ["I","was","expecting","to","see","the",D.dullyellow "of","keyword","next."] - - CaseIndentExpr row col -> - toUnfinishCaseReport source row col startRow startCol $ - D.reflow "I was expecting to see a expression next." - - CaseIndentPattern row col -> - toUnfinishCaseReport source row col startRow startCol $ - D.reflow "I was expecting to see a pattern next." - - CaseIndentArrow row col -> - toUnfinishCaseReport source row col startRow startCol $ - D.fillSep - ["I","just","saw","a","pattern,","so","I","was","expecting" - ,"to","see","a",D.dullyellow "->","next." - ] - - CaseIndentBranch row col -> - toUnfinishCaseReport source row col startRow startCol $ - D.reflow $ - "I was expecting to see an expression next. What should I do when\ - \ I run into this particular pattern?" - - CasePatternAlignment indent row col -> - toUnfinishCaseReport source row col startRow startCol $ - D.reflow $ - "I suspect this is a pattern that is not indented far enough? (" ++ show indent ++ " spaces)" - - -toUnfinishCaseReport :: Code.Source -> Row -> Col -> Row -> Col -> D.Doc -> Report.Report -toUnfinishCaseReport source row col startRow startCol message = - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - in - Report.Report "UNFINISHED CASE" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I was partway through parsing a `case` expression, but I got stuck here:" - , - D.stack - [ message - , noteForCaseError - ] - ) - - -noteForCaseError :: D.Doc -noteForCaseError = - D.stack - [ D.toSimpleNote $ - "Here is an example of a valid `case` expression for reference." - , D.vcat $ - [ D.indent 4 $ D.fillSep [D.cyan "case","maybeWidth",D.cyan "of"] - , D.indent 6 $ D.fillSep [D.blue "Just","width","->"] - , D.indent 8 $ D.fillSep ["width","+",D.dullyellow "200"] - , "" - , D.indent 6 $ D.fillSep [D.blue "Nothing","->"] - , D.indent 8 $ D.fillSep [D.dullyellow "400"] - ] - , D.reflow $ - "Notice the indentation. Each pattern is aligned, and each branch is indented\ - \ a bit more than the corresponding pattern. That is important!" - ] - - -noteForCaseIndentError :: D.Doc -noteForCaseIndentError = - D.stack - [ D.toSimpleNote $ - "Sometimes I get confused by indentation, so try to make your `case` look\ - \ something like this:" - , D.vcat $ - [ D.indent 4 $ D.fillSep [D.cyan "case","maybeWidth",D.cyan "of"] - , D.indent 6 $ D.fillSep [D.blue "Just","width","->"] - , D.indent 8 $ D.fillSep ["width","+",D.dullyellow "200"] - , "" - , D.indent 6 $ D.fillSep [D.blue "Nothing","->"] - , D.indent 8 $ D.fillSep [D.dullyellow "400"] - ] - , D.reflow $ - "Notice the indentation! Patterns are aligned with each other. Same indentation.\ - \ The expressions after each arrow are all indented a bit more than the patterns.\ - \ That is important!" - ] - - - --- IF - - -toIfReport :: Code.Source -> Context -> If -> Row -> Col -> Report.Report -toIfReport source context if_ startRow startCol = - case if_ of - IfSpace space row col -> - toSpaceReport source space row col - - IfThen row col -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - in - Report.Report "UNFINISHED IF" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I was expecting to see more of this `if` expression, but I got stuck here:" - , - D.fillSep $ - ["I","was","expecting","to","see","the",D.cyan "then","keyword","next." - ] - ) - - IfElse row col -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - in - Report.Report "UNFINISHED IF" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I was expecting to see more of this `if` expression, but I got stuck here:" - , - D.fillSep $ - ["I","was","expecting","to","see","the",D.cyan "else","keyword","next." - ] - ) - - IfElseBranchStart row col -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - in - Report.Report "UNFINISHED IF" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I just saw the start of an `else` branch, but then I got stuck here:" - , - D.reflow $ - "I was expecting to see an expression next. Maybe it is not filled in yet?" - ) - - IfCondition expr row col -> - toExprReport source (InNode NCond startRow startCol context) expr row col - - IfThenBranch expr row col -> - toExprReport source (InNode NThen startRow startCol context) expr row col - - IfElseBranch expr row col -> - toExprReport source (InNode NElse startRow startCol context) expr row col - - IfIndentCondition row col -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - in - Report.Report "UNFINISHED IF" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I was expecting to see more of this `if` expression, but I got stuck here:" - , - D.stack - [ D.fillSep $ - ["I","was","expecting","to","see","an","expression","like",D.dullyellow "x < 0" - ,"that","evaluates","to","True","or","False." - ] - , D.toSimpleNote $ - "I can be confused by indentation. Maybe something is not indented enough?" - ] - ) - - IfIndentThen row col -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - in - Report.Report "UNFINISHED IF" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I was expecting to see more of this `if` expression, but I got stuck here:" - , - D.stack - [ D.fillSep $ - ["I","was","expecting","to","see","the",D.cyan "then","keyword","next." - ] - , D.toSimpleNote $ - "I can be confused by indentation. Maybe something is not indented enough?" - ] - ) - - IfIndentThenBranch row col -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - in - Report.Report "UNFINISHED IF" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I got stuck after the start of this `then` branch:" - , - D.stack - [ D.reflow $ - "I was expecting to see an expression next. Maybe it is not filled in yet?" - , D.toSimpleNote $ - "I can be confused by indentation, so if the `then` branch is already\ - \ present, it may not be indented enough for me to recognize it." - ] - ) - - IfIndentElseBranch row col -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - in - Report.Report "UNFINISHED IF" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I got stuck after the start of this `else` branch:" - , - D.stack - [ D.reflow $ - "I was expecting to see an expression next. Maybe it is not filled in yet?" - , D.toSimpleNote $ - "I can be confused by indentation, so if the `else` branch is already\ - \ present, it may not be indented enough for me to recognize it." - ] - ) - - IfIndentElse row col -> - case Code.nextLineStartsWithKeyword "else" source row of - Just (elseRow, elseCol) -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position elseRow elseCol) - region = toWiderRegion elseRow elseCol 4 - in - Report.Report "WEIRD ELSE BRANCH" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I was partway through an `if` expression when I got stuck here:" - , - D.fillSep $ - ["I","think","this",D.cyan "else","keyword","needs","to","be","indented","more." - ,"Try","adding","some","spaces","before","it." - ] - ) - - Nothing -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - in - Report.Report "UNFINISHED IF" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I was expecting to see an `else` branch after this:" - , - D.stack - [ D.fillSep - ["I","know","what","to","do","when","the","condition","is","True," - ,"but","what","happens","when","it","is","False?" - ,"Add","an",D.cyan "else","branch","to","handle","that","scenario!" - ] - ] - ) - - - --- RECORD - - -toRecordReport :: Code.Source -> Context -> Record -> Row -> Col -> Report.Report -toRecordReport source context record startRow startCol = - case record of - RecordOpen row col -> - case Code.whatIsNext source row col of - Code.Keyword keyword -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toKeywordRegion row col keyword - in - Report.Report "RESERVED WORD" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I just started parsing a record, but I got stuck on this field name:" - , - D.reflow $ - "It looks like you are trying to use `" ++ keyword ++ "` as a field name, but \ - \ that is a reserved word. Try using a different name!" - ) - - _ -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - in - Report.Report "PROBLEM IN RECORD" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I just started parsing a record, but I got stuck here:" - , - D.stack - [ D.fillSep - ["I","was","expecting","to","see","a","record","field","defined","next," - ,"so","I","am","looking","for","a","name","like" - ,D.dullyellow "userName","or",D.dullyellow "plantHeight" <> "." - ] - , D.toSimpleNote $ - "Field names must start with a lower-case letter. After that, you can use\ - \ any sequence of letters, numbers, and underscores." - , noteForRecordError - ] - ) - - RecordEnd row col -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - in - Report.Report "PROBLEM IN RECORD" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I am partway through parsing a record, but I got stuck here:" - , - D.stack - [ D.fillSep - ["I","was","expecting","to","see","a","closing","curly","brace","before","this," - ,"so","try","adding","a",D.dullyellow "}","and","see","if","that","helps?" - ] - , D.toSimpleNote $ - "When I get stuck like this, it usually means that there is a missing parenthesis\ - \ or bracket somewhere earlier. It could also be a stray keyword or operator." - ] - ) - - RecordField row col -> - case Code.whatIsNext source row col of - Code.Keyword keyword -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toKeywordRegion row col keyword - in - Report.Report "RESERVED WORD" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I am partway through parsing a record, but I got stuck on this field name:" - , - D.reflow $ - "It looks like you are trying to use `" ++ keyword ++ "` as a field name, but \ - \ that is a reserved word. Try using a different name!" - ) - - Code.Other (Just ',') -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - in - Report.Report "EXTRA COMMA" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I am partway through parsing a record, but I got stuck here:" - , - D.stack - [ D.reflow $ - "I am seeing two commas in a row. This is the second one!" - , D.reflow $ - "Just delete one of the commas and you should be all set!" - , noteForRecordError - ] - ) - - Code.Close _ '}' -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - in - Report.Report "EXTRA COMMA" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I am partway through parsing a record, but I got stuck here:" - , - D.stack - [ D.reflow $ - "Trailing commas are not allowed in records. Try deleting the comma that appears\ - \ before this closing curly brace." - , noteForRecordError - ] - ) - - _ -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - in - Report.Report "PROBLEM IN RECORD" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I am partway through parsing a record, but I got stuck here:" - , - D.stack - [ D.fillSep - ["I","was","expecting","to","see","another","record","field","defined","next," - ,"so","I","am","looking","for","a","name","like" - ,D.dullyellow "userName","or",D.dullyellow "plantHeight" <> "." - ] - , D.toSimpleNote $ - "Field names must start with a lower-case letter. After that, you can use\ - \ any sequence of letters, numbers, and underscores." - , noteForRecordError - ] - ) - - RecordEquals row col -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - in - Report.Report "PROBLEM IN RECORD" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I am partway through parsing a record, but I got stuck here:" - , - D.stack - [ D.fillSep $ - ["I","just","saw","a","field","name,","so","I","was","expecting","to","see" - ,"an","equals","sign","next.","So","try","putting","an",D.green "=","sign","here?" - ] - , noteForRecordError - ] - ) - - RecordExpr expr row col -> - toExprReport source (InNode NRecord startRow startCol context) expr row col - - RecordSpace space row col -> - toSpaceReport source space row col - - RecordIndentOpen row col -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - in - Report.Report "UNFINISHED RECORD" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I just saw the opening curly brace of a record, but then I got stuck here:" - , - D.stack - [ D.fillSep $ - ["I","am","expecting","a","record","like",D.dullyellow "{ x = 3, y = 4 }","here." - ,"Try","defining","some","fields","of","your","own?" - ] - , noteForRecordIndentError - ] - ) - - RecordIndentEnd row col -> - case Code.nextLineStartsWithCloseCurly source row of - Just (curlyRow, curlyCol) -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position curlyRow curlyCol) - region = toRegion curlyRow curlyCol - in - Report.Report "NEED MORE INDENTATION" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I was partway through parsing a record, but I got stuck here:" - , - D.stack - [ D.reflow $ - "I need this curly brace to be indented more. Try adding some spaces before it!" - , noteForRecordError - ] - ) - - Nothing -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - in - Report.Report "UNFINISHED RECORD" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I was partway through parsing a record, but I got stuck here:" - , - D.stack - [ D.fillSep $ - ["I","was","expecting","to","see","a","closing","curly","brace","next." - ,"Try","putting","a",D.green "}","next","and","see","if","that","helps?" - ] - , noteForRecordIndentError - ] - ) - - RecordIndentField row col -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - in - Report.Report "UNFINISHED RECORD" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I am partway through parsing a record, but I got stuck after that last comma:" - , - D.stack - [ D.reflow $ - "Trailing commas are not allowed in records, so the fix may be to\ - \ delete that last comma? Or maybe you were in the middle of defining\ - \ an additional field?" - , noteForRecordError - ] - ) - - RecordIndentEquals row col -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - in - Report.Report "UNFINISHED RECORD" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I am partway through parsing a record. I just saw a record\ - \ field, so I was expecting to see an equals sign next:" - , - D.stack - [ D.fillSep $ - ["Try","putting","an",D.green "=","followed","by","an","expression?" - ] - , noteForRecordIndentError - ] - ) - - RecordIndentExpr row col -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - in - Report.Report "UNFINISHED RECORD" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I am partway through parsing a record, and I was expecting to run into an expression next:" - , - D.stack - [ D.fillSep $ - ["Try","putting","something","like" - ,D.dullyellow "42","or",D.dullyellow"\"hello\"","for","now?" - ] - , noteForRecordIndentError - ] - ) - - -noteForRecordError :: D.Doc -noteForRecordError = - D.stack $ - [ D.toSimpleNote - "If you are trying to define a record across multiple lines, I recommend using this format:" - , D.indent 4 $ D.vcat $ - [ "{ name = " <> D.dullyellow "\"Alice\"" - , ", age = " <> D.dullyellow "42" - , ", height = " <> D.dullyellow "1.75" - , "}" - ] - , D.reflow $ - "Notice that each line starts with some indentation. Usually two or four spaces.\ - \ This is the stylistic convention in the Elm ecosystem." - ] - - -noteForRecordIndentError :: D.Doc -noteForRecordIndentError = - D.stack - [ D.toSimpleNote - "I may be confused by indentation. For example, if you are trying to define\ - \ a record across multiple lines, I recommend using this format:" - , D.indent 4 $ D.vcat $ - [ "{ name = " <> D.dullyellow "\"Alice\"" - , ", age = " <> D.dullyellow "42" - , ", height = " <> D.dullyellow "1.75" - , "}" - ] - , D.reflow $ - "Notice that each line starts with some indentation. Usually two or four spaces.\ - \ This is the stylistic convention in the Elm ecosystem!" - ] - - - --- TUPLE - - -toTupleReport :: Code.Source -> Context -> Tuple -> Row -> Col -> Report.Report -toTupleReport source context tuple startRow startCol = - case tuple of - TupleExpr expr row col -> - toExprReport source (InNode NParens startRow startCol context) expr row col - - TupleSpace space row col -> - toSpaceReport source space row col - - TupleEnd row col -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - in - Report.Report "UNFINISHED PARENTHESES" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I was expecting to see a closing parentheses next, but I got stuck here:" - , - D.stack - [ D.fillSep ["Try","adding","a",D.dullyellow ")","to","see","if","that","helps?"] - , D.toSimpleNote $ - "I can get stuck when I run into keywords, operators, parentheses, or brackets\ - \ unexpectedly. So there may be some earlier syntax trouble (like extra parenthesis\ - \ or missing brackets) that is confusing me." - ] - ) - - TupleOperatorClose row col -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - in - Report.Report "UNFINISHED OPERATOR FUNCTION" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow "I was expecting a closing parenthesis here:" - , - D.stack - [ D.fillSep ["Try","adding","a",D.dullyellow ")","to","see","if","that","helps!"] - , D.toSimpleNote $ - "I think I am parsing an operator function right now, so I am expecting to see\ - \ something like (+) or (&&) where an operator is surrounded by parentheses with\ - \ no extra spaces." - ] - ) - - TupleOperatorReserved operator row col -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - in - Report.Report "UNEXPECTED SYMBOL" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I ran into an unexpected symbol here:" - , - D.fillSep $ - case operator of - BadDot -> ["Maybe","you","wanted","a","record","accessor","like",D.dullyellow ".x","or",D.dullyellow ".name","instead?"] - BadPipe -> ["Try",D.dullyellow "(||)","instead?","To","turn","boolean","OR","into","a","function?"] - BadArrow -> ["Maybe","you","wanted",D.dullyellow "(>)","or",D.dullyellow "(>=)","instead?"] - BadEquals -> ["Try",D.dullyellow "(==)","instead?","To","make","a","function","that","checks","equality?"] - BadHasType -> ["Try",D.dullyellow "(::)","instead?","To","add","values","to","the","front","of","lists?"] - ) - - TupleIndentExpr1 row col -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - in - Report.Report "UNFINISHED PARENTHESES" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I just saw an open parenthesis, so I was expecting to see an expression next." - , - D.stack - [ D.fillSep $ - ["Something","like",D.dullyellow "(4 + 5)","or" - ,D.dullyellow "(String.reverse \"desserts\")" <> "." - ,"Anything","where","you","are","putting","parentheses","around","normal","expressions." - ] - , D.toSimpleNote $ - "I can get confused by indentation in cases like this, so\ - \ maybe you have an expression but it is not indented enough?" - ] - ) - - TupleIndentExprN row col -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - in - Report.Report "UNFINISHED TUPLE" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I think I am in the middle of parsing a tuple. I just saw a comma, so I was expecting to see an expression next." - , - D.stack - [ D.fillSep $ - ["A","tuple","looks","like",D.dullyellow "(3,4)","or" - ,D.dullyellow "(\"Tom\",42)" <> "," - ,"so","I","think","there","is","an","expression","missing","here?" - ] - , D.toSimpleNote $ - "I can get confused by indentation in cases like this, so\ - \ maybe you have an expression but it is not indented enough?" - ] - ) - - TupleIndentEnd row col -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - in - Report.Report "UNFINISHED PARENTHESES" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I was expecting to see a closing parenthesis next:" - , - D.stack - [ D.fillSep ["Try","adding","a",D.dullyellow ")","to","see","if","that","helps!"] - , D.toSimpleNote $ - "I can get confused by indentation in cases like this, so\ - \ maybe you have a closing parenthesis but it is not indented enough?" - ] - ) - - -toListReport :: Code.Source -> Context -> List -> Row -> Col -> Report.Report -toListReport source context list startRow startCol = - case list of - ListSpace space row col -> - toSpaceReport source space row col - - ListOpen row col -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - in - Report.Report "UNFINISHED LIST" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I am partway through parsing a list, but I got stuck here:" - , - D.stack - [ D.fillSep - ["I","was","expecting","to","see","a","closing","square","bracket","before","this," - ,"so","try","adding","a",D.dullyellow "]","and","see","if","that","helps?" - ] - , D.toSimpleNote $ - "When I get stuck like this, it usually means that there is a missing parenthesis\ - \ or bracket somewhere earlier. It could also be a stray keyword or operator." - ] - ) - - ListExpr expr row col -> - case expr of - Start r c -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position r c) - region = toRegion r c - in - Report.Report "UNFINISHED LIST" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I was expecting to see another list entry after that last comma:" - , - D.stack - [ D.reflow $ - "Trailing commas are not allowed in lists, so the fix may be to delete the comma?" - , D.toSimpleNote - "I recommend using the following format for lists that span multiple lines:" - , D.indent 4 $ D.vcat $ - [ "[ " <> D.dullyellow "\"Alice\"" - , ", " <> D.dullyellow "\"Bob\"" - , ", " <> D.dullyellow "\"Chuck\"" - , "]" - ] - , D.reflow $ - "Notice that each line starts with some indentation. Usually two or four spaces.\ - \ This is the stylistic convention in the Elm ecosystem." - ] - ) - - _ -> - toExprReport source (InNode NList startRow startCol context) expr row col - - ListEnd row col -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - in - Report.Report "UNFINISHED LIST" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I am partway through parsing a list, but I got stuck here:" - , - D.stack - [ D.fillSep - ["I","was","expecting","to","see","a","closing","square","bracket","before","this," - ,"so","try","adding","a",D.dullyellow "]","and","see","if","that","helps?" - ] - , D.toSimpleNote $ - "When I get stuck like this, it usually means that there is a missing parenthesis\ - \ or bracket somewhere earlier. It could also be a stray keyword or operator." - ] - ) - - ListIndentOpen row col -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - in - Report.Report "UNFINISHED LIST" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I cannot find the end of this list:" - , - D.stack - [ D.fillSep $ - ["You","could","change","it","to","something","like" - ,D.dullyellow "[3,4,5]" - ,"or","even","just" - ,D.dullyellow "[]" <> "." - ,"Anything","where","there","is","an","open","and","close","square","brace," - ,"and","where","the","elements","of","the","list","are","separated","by","commas." - ] - , D.toSimpleNote - "I may be confused by indentation. For example, if you are trying to define\ - \ a list across multiple lines, I recommend using this format:" - , D.indent 4 $ D.vcat $ - [ "[ " <> D.dullyellow "\"Alice\"" - , ", " <> D.dullyellow "\"Bob\"" - , ", " <> D.dullyellow "\"Chuck\"" - , "]" - ] - , D.reflow $ - "Notice that each line starts with some indentation. Usually two or four spaces.\ - \ This is the stylistic convention in the Elm ecosystem." - ] - ) - - ListIndentEnd row col -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - in - Report.Report "UNFINISHED LIST" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I cannot find the end of this list:" - , - D.stack - [ D.fillSep $ - ["You","can","just","add","a","closing",D.dullyellow "]" - ,"right","here,","and","I","will","be","all","set!" - ] - , D.toSimpleNote - "I may be confused by indentation. For example, if you are trying to define\ - \ a list across multiple lines, I recommend using this format:" - , D.indent 4 $ D.vcat $ - [ "[ " <> D.dullyellow "\"Alice\"" - , ", " <> D.dullyellow "\"Bob\"" - , ", " <> D.dullyellow "\"Chuck\"" - , "]" - ] - , D.reflow $ - "Notice that each line starts with some indentation. Usually two or four spaces.\ - \ This is the stylistic convention in the Elm ecosystem." - ] - ) - - ListIndentExpr row col -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - in - Report.Report "UNFINISHED LIST" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I was expecting to see another list entry after this comma:" - , - D.stack - [ D.reflow $ - "Trailing commas are not allowed in lists, so the fix may be to delete the comma?" - , D.toSimpleNote - "I recommend using the following format for lists that span multiple lines:" - , D.indent 4 $ D.vcat $ - [ "[ " <> D.dullyellow "\"Alice\"" - , ", " <> D.dullyellow "\"Bob\"" - , ", " <> D.dullyellow "\"Chuck\"" - , "]" - ] - , D.reflow $ - "Notice that each line starts with some indentation. Usually two or four spaces.\ - \ This is the stylistic convention in the Elm ecosystem." - ] - ) - - -toFuncReport :: Code.Source -> Context -> Func -> Row -> Col -> Report.Report -toFuncReport source context func startRow startCol = - case func of - FuncSpace space row col -> - toSpaceReport source space row col - - FuncArg pattern row col -> - toPatternReport source PArg pattern row col - - FuncBody expr row col -> - toExprReport source (InNode NFunc startRow startCol context) expr row col - - FuncArrow row col -> - case Code.whatIsNext source row col of - Code.Keyword keyword -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toKeywordRegion row col keyword - in - Report.Report "RESERVED WORD" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I was parsing an anonymous function, but I got stuck here:" - , - D.reflow $ - "It looks like you are trying to use `" ++ keyword ++ "` as an argument, but\ - \ it is a reserved word in this language. Try using a different argument name!" - ) - - _ -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - in - Report.Report "UNFINISHED ANONYMOUS FUNCTION" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I just saw the beginning of an anonymous function, so I was expecting to see an arrow next:" - , - D.fillSep $ - ["The","syntax","for","anonymous","functions","is" - ,D.dullyellow "(\\x -> x + 1)" - ,"so","I","am","missing","the","arrow","and","the","body","of","the","function." - ] - ) - - FuncIndentArg row col -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - in - Report.Report "MISSING ARGUMENT" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I just saw the beginning of an anonymous function, so I was expecting to see an argument next:" - , - D.stack - [ D.fillSep - ["Something","like",D.dullyellow"x","or",D.dullyellow "name" <> "." - ,"Anything","that","starts","with","a","lower","case","letter!" - ] - , D.toSimpleNote $ - "The syntax for anonymous functions is (\\x -> x + 1) where the backslash\ - \ is meant to look a bit like a lambda if you squint. This visual pun seemed\ - \ like a better idea at the time!" - ] - ) - - FuncIndentArrow row col -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - in - Report.Report "UNFINISHED ANONYMOUS FUNCTION" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I just saw the beginning of an anonymous function, so I was expecting to see an arrow next:" - , - D.stack - [ D.fillSep $ - ["The","syntax","for","anonymous","functions","is" - ,D.dullyellow "(\\x -> x + 1)" - ,"so","I","am","missing","the","arrow","and","the","body","of","the","function." - ] - , D.toSimpleNote $ - "It is possible that I am confused about indetation! I generally recommend\ - \ switching to named functions if the definition cannot fit inline nicely, so\ - \ either (1) try to fit the whole anonymous function on one line or (2) break\ - \ the whole thing out into a named function. Things tend to be clearer that way!" - ] - ) - - FuncIndentBody row col -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - in - Report.Report "UNFINISHED ANONYMOUS FUNCTION" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I was expecting to see the body of your anonymous function next:" - , - D.stack - [ D.fillSep $ - ["The","syntax","for","anonymous","functions","is" - ,D.dullyellow "(\\x -> x + 1)" - ,"so","I","am","missing","all","the","stuff","after","the","arrow!" - ] - , D.toSimpleNote $ - "It is possible that I am confused about indetation! I generally recommend\ - \ switching to named functions if the definition cannot fit inline nicely, so\ - \ either (1) try to fit the whole anonymous function on one line or (2) break\ - \ the whole thing out into a named function. Things tend to be clearer that way!" - ] - ) - - - --- PATTERN - - -data PContext - = PCase - | PArg - | PLet - - -toPatternReport :: Code.Source -> PContext -> Pattern -> Row -> Col -> Report.Report -toPatternReport source context pattern startRow startCol = - case pattern of - PRecord record row col -> - toPRecordReport source record row col - - PTuple tuple row col -> - toPTupleReport source context tuple row col - - PList list row col -> - toPListReport source context list row col - - PStart row col -> - case Code.whatIsNext source row col of - Code.Keyword keyword -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toKeywordRegion row col keyword - inThisThing = - case context of - PArg -> "as an argument" - PCase -> "in this pattern" - PLet -> "in this pattern" - in - Report.Report "RESERVED WORD" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "It looks like you are trying to use `" ++ keyword ++ "` " ++ inThisThing ++ ":" - , - D.reflow $ - "This is a reserved word! Try using some other name?" - ) - - Code.Operator "-" -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - in - Report.Report "UNEXPECTED SYMBOL" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I ran into a minus sign unexpectedly in this pattern:" - , - D.reflow $ - "It is not possible to pattern match on negative numbers at this\ - \ time. Try using an `if` expression for that sort of thing for now." - ) - - _ -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - in - Report.Report "PROBLEM IN PATTERN" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I wanted to parse a pattern next, but I got stuck here:" - , - D.fillSep $ - ["I","am","not","sure","why","I","am","getting","stuck","exactly." - ,"I","just","know","that","I","want","a","pattern","next." - ,"Something","as","simple","as" - ,D.dullyellow "maybeHeight","or",D.dullyellow "result" - ,"would","work!" - ] - ) - - PChar char row col -> - toCharReport source char row col - - PString string row col -> - toStringReport source string row col - - PNumber number row col -> - toNumberReport source number row col - - PFloat width row col -> - let - region = toWiderRegion row col width - in - Report.Report "UNEXPECTED PATTERN" region [] $ - Code.toSnippet source region Nothing - ( - D.reflow $ - "I cannot pattern match with floating point numbers:" - , - D.fillSep $ - ["Equality","on","floats","can","be","unreliable,","so","you","usually","want" - ,"to","check","that","they","are","nearby","with","some","sort","of" - ,D.dullyellow "(abs (actual - expected) < 0.001)","check." - ] - ) - - PAlias row col -> - let - region = toRegion row col - in - Report.Report "UNFINISHED PATTERN" region [] $ - Code.toSnippet source region Nothing $ - ( - D.reflow $ - "I was expecting to see a variable name after the `as` keyword:" - , - D.stack - [ D.fillSep $ - ["The","`as`","keyword","lets","you","write","patterns","like" - ,"((" <> D.dullyellow "x" <> "," <> D.dullyellow "y" <> ") " <> D.cyan "as" <> D.dullyellow " point" <> ")" - ,"so","you","can","refer","to","individual","parts","of","the","tuple","with" - ,D.dullyellow "x","and",D.dullyellow "y","or","you","refer","to","the","whole" - ,"thing","with",D.dullyellow "point" <> "." - ] - , D.reflow $ - "So I was expecting to see a variable name after the `as` keyword here. Sometimes\ - \ people just want to use `as` as a variable name though. Try using a different name\ - \ in that case!" - ] - ) - - PWildcardNotVar name width row col -> - let - region = toWiderRegion row col (fromIntegral width) - examples = - case dropWhile (=='_') (Name.toChars name) of - [] -> [D.dullyellow "x","or",D.dullyellow "age"] - c:cs -> [D.dullyellow (D.fromChars (Char.toLower c : cs))] - in - Report.Report "UNEXPECTED NAME" region [] $ - Code.toSnippet source region Nothing $ - ( - D.reflow $ - "Variable names cannot start with underscores like this:" - , - D.fillSep $ - ["You","can","either","have","an","underscore","like",D.dullyellow "_","to" - ,"ignore","the","value,","or","you","can","have","a","name","like" - ] ++ examples ++ ["to","use","the","matched","value." ] - ) - - PSpace space row col -> - toSpaceReport source space row col - - PIndentStart row col -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - in - Report.Report "UNFINISHED PATTERN" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I wanted to parse a pattern next, but I got stuck here:" - , - D.stack - [ D.fillSep $ - ["I","am","not","sure","why","I","am","getting","stuck","exactly." - ,"I","just","know","that","I","want","a","pattern","next." - ,"Something","as","simple","as" - ,D.dullyellow "maybeHeight","or",D.dullyellow "result" - ,"would","work!" - ] - , D.toSimpleNote $ - "I can get confused by indentation. If you think there is a pattern next, maybe\ - \ it needs to be indented a bit more?" - ] - ) - - PIndentAlias row col -> - let - region = toRegion row col - in - Report.Report "UNFINISHED PATTERN" region [] $ - Code.toSnippet source region Nothing $ - ( - D.reflow $ - "I was expecting to see a variable name after the `as` keyword:" - , - D.stack - [ D.fillSep $ - ["The","`as`","keyword","lets","you","write","patterns","like" - ,"((" <> D.dullyellow "x" <> "," <> D.dullyellow "y" <> ") " <> D.cyan "as" <> D.dullyellow " point" <> ")" - ,"so","you","can","refer","to","individual","parts","of","the","tuple","with" - ,D.dullyellow "x","and",D.dullyellow "y","or","you","refer","to","the","whole" - ,"thing","with",D.dullyellow "point." - ] - , D.reflow $ - "So I was expecting to see a variable name after the `as` keyword here. Sometimes\ - \ people just want to use `as` as a variable name though. Try using a different name\ - \ in that case!" - ] - ) - - -toPRecordReport :: Code.Source -> PRecord -> Row -> Col -> Report.Report -toPRecordReport source record startRow startCol = - case record of - PRecordOpen row col -> - toUnfinishRecordPatternReport source row col startRow startCol $ - D.reflow "I was expecting to see a field name next." - - PRecordEnd row col -> - toUnfinishRecordPatternReport source row col startRow startCol $ - D.fillSep - ["I","was","expecting","to","see","a","closing","curly","brace","next." - ,"Try","adding","a",D.dullyellow "}","here?" - ] - - PRecordField row col -> - case Code.whatIsNext source row col of - Code.Keyword keyword -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toKeywordRegion row col keyword - in - Report.Report "RESERVED WORD" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I was not expecting to see `" ++ keyword ++ "` as a record field name:" - , - D.reflow $ - "This is a reserved word, not available for variable names. Try another name!" - ) - - _ -> - toUnfinishRecordPatternReport source row col startRow startCol $ - D.reflow "I was expecting to see a field name next." - - PRecordSpace space row col -> - toSpaceReport source space row col - - PRecordIndentOpen row col -> - toUnfinishRecordPatternReport source row col startRow startCol $ - D.reflow "I was expecting to see a field name next." - - PRecordIndentEnd row col -> - toUnfinishRecordPatternReport source row col startRow startCol $ - D.fillSep - ["I","was","expecting","to","see","a","closing","curly","brace","next." - ,"Try","adding","a",D.dullyellow "}","here?" - ] - - PRecordIndentField row col -> - toUnfinishRecordPatternReport source row col startRow startCol $ - D.reflow "I was expecting to see a field name next." - - -toUnfinishRecordPatternReport :: Code.Source -> Row -> Col -> Row -> Col -> D.Doc -> Report.Report -toUnfinishRecordPatternReport source row col startRow startCol message = - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - in - Report.Report "UNFINISHED RECORD PATTERN" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I was partway through parsing a record pattern, but I got stuck here:" - , - D.stack - [ message - , D.toFancyHint $ - ["A","record","pattern","looks","like",D.dullyellow "{x,y}","or",D.dullyellow "{name,age}" - ,"where","you","list","the","field","names","you","want","to","access." - ] - ] - ) - - - -toPTupleReport :: Code.Source -> PContext -> PTuple -> Row -> Col -> Report.Report -toPTupleReport source context tuple startRow startCol = - case tuple of - PTupleOpen row col -> - case Code.whatIsNext source row col of - Code.Keyword keyword -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toKeywordRegion row col keyword - in - Report.Report "RESERVED WORD" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "It looks like you are trying to use `" ++ keyword ++ "` as a variable name:" - , - D.reflow $ - "This is a reserved word! Try using some other name?" - ) - - _ -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - in - Report.Report "UNFINISHED PARENTHESES" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I just saw an open parenthesis, but I got stuck here:" - , - D.fillSep - ["I","was","expecting","to","see","a","pattern","next." - ,"Maybe","it","will","end","up","being","something" - ,"like",D.dullyellow "(x,y)","or",D.dullyellow "(name, _)" <> "?" - ] - ) - - PTupleEnd row col -> - case Code.whatIsNext source row col of - Code.Keyword keyword -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toKeywordRegion row col keyword - in - Report.Report "RESERVED WORD" region [] $ - Code.toSnippet source surroundings (Just region) $ - ( - D.reflow $ - "I ran into a reserved word in this pattern:" - , - D.reflow $ - "The `" ++ keyword ++ "` keyword is reserved. Try using a different name instead!" - ) - - Code.Operator op -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toKeywordRegion row col op - in - Report.Report "UNEXPECTED SYMBOL" region [] $ - Code.toSnippet source surroundings (Just region) $ - ( - D.reflow $ - "I ran into the " ++ op ++ " symbol unexpectedly in this pattern:" - , - D.reflow $ - "Only the :: symbol that works in patterns. It is useful if you\ - \ are pattern matching on lists, trying to get the first element\ - \ off the front. Did you want that instead?" - ) - - Code.Close term bracket -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - in - Report.Report ("STRAY " ++ map Char.toUpper term) region [] $ - Code.toSnippet source surroundings (Just region) $ - ( - D.reflow $ - "I ran into a an unexpected " ++ term ++ " in this pattern:" - , - D.reflow $ - "This " ++ bracket : " does not match up with an earlier open " ++ term ++ ". Try deleting it?" - ) - - _ -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - in - Report.Report "UNFINISHED PARENTHESES" region [] $ - Code.toSnippet source surroundings (Just region) $ - ( - D.reflow $ - "I was partway through parsing a pattern, but I got stuck here:" - , - D.fillSep - ["I","was","expecting","a","closing","parenthesis","next,","so" - ,"try","adding","a",D.dullyellow ")","to","see","if","that","helps?" - ] - ) - - PTupleExpr pattern row col -> - toPatternReport source context pattern row col - - PTupleSpace space row col -> - toSpaceReport source space row col - - PTupleIndentEnd row col -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - in - Report.Report "UNFINISHED PARENTHESES" region [] $ - Code.toSnippet source surroundings (Just region) $ - ( - D.reflow $ - "I was expecting a closing parenthesis next:" - , - D.stack - [ D.fillSep ["Try","adding","a",D.dullyellow ")","to","see","if","that","helps?"] - , D.toSimpleNote $ - "I can get confused by indentation in cases like this, so\ - \ maybe you have a closing parenthesis but it is not indented enough?" - ] - ) - - PTupleIndentExpr1 row col -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - in - Report.Report "UNFINISHED PARENTHESES" region [] $ - Code.toSnippet source surroundings (Just region) $ - ( - D.reflow $ - "I just saw an open parenthesis, but then I got stuck here:" - , - D.fillSep - ["I","was","expecting","to","see","a","pattern","next." - ,"Maybe","it","will","end","up","being","something" - ,"like",D.dullyellow "(x,y)","or",D.dullyellow "(name, _)" <> "?" - ] - ) - - PTupleIndentExprN row col -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - in - Report.Report "UNFINISHED TUPLE PATTERN" region [] $ - Code.toSnippet source surroundings (Just region) $ - ( - D.reflow $ - "I am partway through parsing a tuple pattern, but I got stuck here:" - , - D.stack - [ D.fillSep - ["I","was","expecting","to","see","a","pattern","next." - ,"I","am","expecting","the","final","result","to","be","something" - ,"like",D.dullyellow "(x,y)","or",D.dullyellow "(name, _)" <> "." - ] - , D.toSimpleNote $ - "I can get confused by indentation in cases like this, so the problem\ - \ may be that the next part is not indented enough?" - ] - ) - - -toPListReport :: Code.Source -> PContext -> PList -> Row -> Col -> Report.Report -toPListReport source context list startRow startCol = - case list of - PListOpen row col -> - case Code.whatIsNext source row col of - Code.Keyword keyword -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toKeywordRegion row col keyword - in - Report.Report "RESERVED WORD" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "It looks like you are trying to use `" ++ keyword ++ "` to name an element of a list:" - , - D.reflow $ - "This is a reserved word though! Try using some other name?" - ) - - _ -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - in - Report.Report "UNFINISHED LIST PATTERN" region [] $ - Code.toSnippet source surroundings (Just region) $ - ( - D.reflow $ - "I just saw an open square bracket, but then I got stuck here:" - , - D.fillSep ["Try","adding","a",D.dullyellow "]","to","see","if","that","helps?"] - ) - - PListEnd row col -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - in - Report.Report "UNFINISHED LIST PATTERN" region [] $ - Code.toSnippet source surroundings (Just region) $ - ( - D.reflow $ - "I was expecting a closing square bracket to end this list pattern:" - , - D.fillSep ["Try","adding","a",D.dullyellow "]","to","see","if","that","helps?"] - ) - - PListExpr pattern row col -> - toPatternReport source context pattern row col - - PListSpace space row col -> - toSpaceReport source space row col - - PListIndentOpen row col -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - in - Report.Report "UNFINISHED LIST PATTERN" region [] $ - Code.toSnippet source surroundings (Just region) $ - ( - D.reflow $ - "I just saw an open square bracket, but then I got stuck here:" - , - D.stack - [ D.fillSep ["Try","adding","a",D.dullyellow "]","to","see","if","that","helps?"] - , D.toSimpleNote $ - "I can get confused by indentation in cases like this, so\ - \ maybe there is something next, but it is not indented enough?" - ] - ) - - PListIndentEnd row col -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - in - Report.Report "UNFINISHED LIST PATTERN" region [] $ - Code.toSnippet source surroundings (Just region) $ - ( - D.reflow $ - "I was expecting a closing square bracket to end this list pattern:" - , - D.stack - [ D.fillSep ["Try","adding","a",D.dullyellow "]","to","see","if","that","helps?"] - , D.toSimpleNote $ - "I can get confused by indentation in cases like this, so\ - \ maybe you have a closing square bracket but it is not indented enough?" - ] - ) - - PListIndentExpr row col -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - in - Report.Report "UNFINISHED LIST PATTERN" region [] $ - Code.toSnippet source surroundings (Just region) $ - ( - D.reflow $ - "I am partway through parsing a list pattern, but I got stuck here:" - , - D.stack - [ D.reflow $ - "I was expecting to see another pattern next. Maybe a variable name." - , D.toSimpleNote $ - "I can get confused by indentation in cases like this, so\ - \ maybe there is more to this pattern but it is not indented enough?" - ] - ) - - - --- TYPES - - -data TContext - = TC_Annotation Name.Name - | TC_CustomType - | TC_TypeAlias - | TC_Port - - -toTypeReport :: Code.Source -> TContext -> Type -> Row -> Col -> Report.Report -toTypeReport source context tipe startRow startCol = - case tipe of - TRecord record row col -> - toTRecordReport source context record row col - - TTuple tuple row col -> - toTTupleReport source context tuple row col - - TStart row col -> - case Code.whatIsNext source row col of - Code.Keyword keyword -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toKeywordRegion row col keyword - in - Report.Report "RESERVED WORD" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I was expecting to see a type next, but I got stuck on this reserved word:" - , - D.reflow $ - "It looks like you are trying to use `" ++ keyword ++ "` as a type variable, but \ - \ it is a reserved word. Try using a different name!" - ) - - _ -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - - thing = - case context of - TC_Annotation _ -> "type annotation" - TC_CustomType -> "custom type" - TC_TypeAlias -> "type alias" - TC_Port -> "port" - - something = - case context of - TC_Annotation name -> "the `" ++ Name.toChars name ++ "` type annotation" - TC_CustomType -> "a custom type" - TC_TypeAlias -> "a type alias" - TC_Port -> "a port" - in - Report.Report ("PROBLEM IN " ++ map Char.toUpper thing) region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I was partway through parsing " ++ something ++ ", but I got stuck here:" - , - D.fillSep $ - ["I","was","expecting","to","see","a","type","next." - ,"Try","putting",D.dullyellow "Int","or",D.dullyellow "String","for","now?" - ] - ) - - TSpace space row col -> - toSpaceReport source space row col - - TIndentStart row col -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - - thing = - case context of - TC_Annotation _ -> "type annotation" - TC_CustomType -> "custom type" - TC_TypeAlias -> "type alias" - TC_Port -> "port" - in - Report.Report ("UNFINISHED " ++ map Char.toUpper thing) region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I was partway through parsing a " ++ thing ++ ", but I got stuck here:" - , - D.stack - [ D.fillSep $ - ["I","was","expecting","to","see","a","type","next." - ,"Try","putting",D.dullyellow "Int","or",D.dullyellow "String","for","now?" - ] - , D.toSimpleNote $ - "I can get confused by indentation. If you think there is already a type\ - \ next, maybe it is not indented enough?" - ] - ) - - -toTRecordReport :: Code.Source -> TContext -> TRecord -> Row -> Col -> Report.Report -toTRecordReport source context record startRow startCol = - case record of - TRecordOpen row col -> - case Code.whatIsNext source row col of - Code.Keyword keyword -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toKeywordRegion row col keyword - in - Report.Report "RESERVED WORD" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I just started parsing a record type, but I got stuck on this field name:" - , - D.reflow $ - "It looks like you are trying to use `" ++ keyword ++ "` as a field name, but \ - \ that is a reserved word. Try using a different name!" - ) - - _ -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - in - Report.Report "UNFINISHED RECORD TYPE" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I just started parsing a record type, but I got stuck here:" - , - D.fillSep - ["Record","types","look","like",D.dullyellow "{ name : String, age : Int }," - ,"so","I","was","expecting","to","see","a","field","name","next." - ] - ) - - TRecordEnd row col -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - in - Report.Report "UNFINISHED RECORD TYPE" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I am partway through parsing a record type, but I got stuck here:" - , - D.stack - [ D.fillSep - ["I","was","expecting","to","see","a","closing","curly","brace","before","this," - ,"so","try","adding","a",D.dullyellow "}","and","see","if","that","helps?" - ] - , D.toSimpleNote $ - "When I get stuck like this, it usually means that there is a missing parenthesis\ - \ or bracket somewhere earlier. It could also be a stray keyword or operator." - ] - ) - - TRecordField row col -> - case Code.whatIsNext source row col of - Code.Keyword keyword -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toKeywordRegion row col keyword - in - Report.Report "RESERVED WORD" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I am partway through parsing a record type, but I got stuck on this field name:" - , - D.reflow $ - "It looks like you are trying to use `" ++ keyword ++ "` as a field name, but \ - \ that is a reserved word. Try using a different name!" - ) - - Code.Other (Just ',') -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - in - Report.Report "EXTRA COMMA" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I am partway through parsing a record type, but I got stuck here:" - , - D.stack - [ D.reflow $ - "I am seeing two commas in a row. This is the second one!" - , D.reflow $ - "Just delete one of the commas and you should be all set!" - , noteForRecordTypeError - ] - ) - - Code.Close _ '}' -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - in - Report.Report "EXTRA COMMA" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I am partway through parsing a record type, but I got stuck here:" - , - D.stack - [ D.reflow $ - "Trailing commas are not allowed in record types. Try deleting the comma that\ - \ appears before this closing curly brace." - , noteForRecordTypeError - ] - ) - - _ -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - in - Report.Report "PROBLEM IN RECORD TYPE" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I am partway through parsing a record type, but I got stuck here:" - , - D.stack - [ D.fillSep - ["I","was","expecting","to","see","another","record","field","defined","next," - ,"so","I","am","looking","for","a","name","like" - ,D.dullyellow "userName","or",D.dullyellow "plantHeight" <> "." - ] - , noteForRecordTypeError - ] - ) - - TRecordColon row col -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - in - Report.Report "UNFINISHED RECORD TYPE" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I am partway through parsing a record type, but I got stuck here:" - , - D.stack - [ D.fillSep $ - ["I","just","saw","a","field","name,","so","I","was","expecting","to","see" - ,"a","colon","next.","So","try","putting","an",D.green ":","sign","here?" - ] - , noteForRecordTypeError - ] - ) - - TRecordType tipe row col -> - toTypeReport source context tipe row col - - TRecordSpace space row col -> - toSpaceReport source space row col - - TRecordIndentOpen row col -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - in - Report.Report "UNFINISHED RECORD TYPE" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I just saw the opening curly brace of a record type, but then I got stuck here:" - , - D.stack - [ D.fillSep $ - ["I","am","expecting","a","record","like",D.dullyellow "{ name : String, age : Int }","here." - ,"Try","defining","some","fields","of","your","own?" - ] - , noteForRecordTypeIndentError - ] - ) - - TRecordIndentEnd row col -> - case Code.nextLineStartsWithCloseCurly source row of - Just (curlyRow, curlyCol) -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position curlyRow curlyCol) - region = toRegion curlyRow curlyCol - in - Report.Report "NEED MORE INDENTATION" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I was partway through parsing a record type, but I got stuck here:" - , - D.stack - [ D.reflow $ - "I need this curly brace to be indented more. Try adding some spaces before it!" - , noteForRecordTypeError - ] - ) - - Nothing -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - in - Report.Report "UNFINISHED RECORD TYPE" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I was partway through parsing a record type, but I got stuck here:" - , - D.stack - [ D.fillSep $ - ["I","was","expecting","to","see","a","closing","curly","brace","next." - ,"Try","putting","a",D.green "}","next","and","see","if","that","helps?" - ] - , noteForRecordTypeIndentError - ] - ) - - TRecordIndentField row col -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - in - Report.Report "UNFINISHED RECORD TYPE" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I am partway through parsing a record type, but I got stuck after that last comma:" - , - D.stack - [ D.reflow $ - "Trailing commas are not allowed in record types, so the fix may be to\ - \ delete that last comma? Or maybe you were in the middle of defining\ - \ an additional field?" - , noteForRecordTypeIndentError - ] - ) - - TRecordIndentColon row col -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - in - Report.Report "UNFINISHED RECORD TYPE" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I am partway through parsing a record type. I just saw a record\ - \ field, so I was expecting to see a colon next:" - , - D.stack - [ D.fillSep $ - ["Try","putting","an",D.green ":","followed","by","a","type?" - ] - , noteForRecordTypeIndentError - ] - ) - - TRecordIndentType row col -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - in - Report.Report "UNFINISHED RECORD TYPE" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I am partway through parsing a record type, and I was expecting to run into a type next:" - , - D.stack - [ D.fillSep $ - ["Try","putting","something","like" - ,D.dullyellow "Int","or",D.dullyellow "String","for","now?" - ] - , noteForRecordTypeIndentError - ] - ) - - -noteForRecordTypeError :: D.Doc -noteForRecordTypeError = - D.stack $ - [ D.toSimpleNote - "If you are trying to define a record type across multiple lines, I recommend using this format:" - , D.indent 4 $ D.vcat $ - [ "{ name : String" - , ", age : Int" - , ", height : Float" - , "}" - ] - , D.reflow $ - "Notice that each line starts with some indentation. Usually two or four spaces.\ - \ This is the stylistic convention in the Elm ecosystem." - ] - - -noteForRecordTypeIndentError :: D.Doc -noteForRecordTypeIndentError = - D.stack $ - [ D.toSimpleNote - "I may be confused by indentation. For example, if you are trying to define\ - \ a record type across multiple lines, I recommend using this format:" - , D.indent 4 $ D.vcat $ - [ "{ name : String" - , ", age : Int" - , ", height : Float" - , "}" - ] - , D.reflow $ - "Notice that each line starts with some indentation. Usually two or four spaces.\ - \ This is the stylistic convention in the Elm ecosystem." - ] - - -toTTupleReport :: Code.Source -> TContext -> TTuple -> Row -> Col -> Report.Report -toTTupleReport source context tuple startRow startCol = - case tuple of - TTupleOpen row col -> - case Code.whatIsNext source row col of - Code.Keyword keyword -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toKeywordRegion row col keyword - in - Report.Report "RESERVED WORD" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I ran into a reserved word unexpectedly:" - , - D.reflow $ - "It looks like you are trying to use `" ++ keyword ++ "` as a variable name, but \ - \ it is a reserved word. Try using a different name!" - ) - - _ -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - in - Report.Report "UNFINISHED PARENTHESES" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I just saw an open parenthesis, so I was expecting to see a type next." - , - D.fillSep $ - ["Something","like",D.dullyellow "(Maybe Int)","or" - ,D.dullyellow "(List Person)" <> "." - ,"Anything","where","you","are","putting","parentheses","around","normal","types." - ] - ) - - TTupleEnd row col -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - in - Report.Report "UNFINISHED PARENTHESES" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I was expecting to see a closing parenthesis next, but I got stuck here:" - , - D.stack - [ D.fillSep ["Try","adding","a",D.dullyellow ")","to","see","if","that","helps?"] - , D.toSimpleNote $ - "I can get stuck when I run into keywords, operators, parentheses, or brackets\ - \ unexpectedly. So there may be some earlier syntax trouble (like extra parenthesis\ - \ or missing brackets) that is confusing me." - ] - ) - - TTupleType tipe row col -> - toTypeReport source context tipe row col - - TTupleSpace space row col -> - toSpaceReport source space row col - - TTupleIndentType1 row col -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - in - Report.Report "UNFINISHED PARENTHESES" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I just saw an open parenthesis, so I was expecting to see a type next." - , - D.stack - [ D.fillSep $ - ["Something","like",D.dullyellow "(Maybe Int)","or" - ,D.dullyellow "(List Person)" <> "." - ,"Anything","where","you","are","putting","parentheses","around","normal","types." - ] - , D.toSimpleNote $ - "I can get confused by indentation in cases like this, so\ - \ maybe you have a type but it is not indented enough?" - ] - ) - - TTupleIndentTypeN row col -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - in - Report.Report "UNFINISHED TUPLE TYPE" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I think I am in the middle of parsing a tuple type. I just saw a comma, so I was expecting to see a type next." - , - D.stack - [ D.fillSep $ - ["A","tuple","type","looks","like",D.dullyellow "(Float,Float)","or" - ,D.dullyellow "(String,Int)" <> "," - ,"so","I","think","there","is","a","type","missing","here?" - ] - , D.toSimpleNote $ - "I can get confused by indentation in cases like this, so\ - \ maybe you have an expression but it is not indented enough?" - ] - ) - - TTupleIndentEnd row col -> - let - surroundings = A.Region (A.Position startRow startCol) (A.Position row col) - region = toRegion row col - in - Report.Report "UNFINISHED PARENTHESES" region [] $ - Code.toSnippet source surroundings (Just region) - ( - D.reflow $ - "I was expecting to see a closing parenthesis next:" - , - D.stack - [ D.fillSep ["Try","adding","a",D.dullyellow ")","to","see","if","that","helps!"] - , D.toSimpleNote $ - "I can get confused by indentation in cases like this, so\ - \ maybe you have a closing parenthesis but it is not indented enough?" - ] - ) diff --git a/compiler/src/Reporting/Error/Type.hs b/compiler/src/Reporting/Error/Type.hs deleted file mode 100644 index 4ee1580f66..0000000000 --- a/compiler/src/Reporting/Error/Type.hs +++ /dev/null @@ -1,1613 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE OverloadedStrings #-} -module Reporting.Error.Type - ( Error(..) - -- expectations - , Expected(..) - , Context(..) - , SubContext(..) - , MaybeName(..) - , Category(..) - , PExpected(..) - , PContext(..) - , PCategory(..) - , typeReplace - , ptypeReplace - -- make reports - , toReport - ) - where - - -import Prelude hiding (round) -import qualified Data.Map as Map -import Data.Monoid ((<>)) -import qualified Data.Name as Name - -import qualified AST.Canonical as Can -import qualified Data.Index as Index -import qualified Reporting.Annotation as A -import qualified Reporting.Doc as D -import qualified Reporting.Render.Code as Code -import qualified Reporting.Render.Type as RT -import qualified Reporting.Render.Type.Localizer as L -import qualified Reporting.Report as Report -import qualified Reporting.Suggest as Suggest -import qualified Type.Error as T - - - --- ERRORS - - -data Error - = BadExpr A.Region Category T.Type (Expected T.Type) - | BadPattern A.Region PCategory T.Type (PExpected T.Type) - | InfiniteType A.Region Name.Name T.Type - - - --- EXPRESSION EXPECTATIONS - - -data Expected tipe - = NoExpectation tipe - | FromContext A.Region Context tipe - | FromAnnotation Name.Name Int SubContext tipe - - -data Context - = ListEntry Index.ZeroBased - | Negate - | OpLeft Name.Name - | OpRight Name.Name - | IfCondition - | IfBranch Index.ZeroBased - | CaseBranch Index.ZeroBased - | CallArity MaybeName Int - | CallArg MaybeName Index.ZeroBased - | RecordAccess A.Region (Maybe Name.Name) A.Region Name.Name - | RecordUpdateKeys Name.Name (Map.Map Name.Name Can.FieldUpdate) - | RecordUpdateValue Name.Name - | Destructure - - -data SubContext - = TypedIfBranch Index.ZeroBased - | TypedCaseBranch Index.ZeroBased - | TypedBody - - -data MaybeName - = FuncName Name.Name - | CtorName Name.Name - | OpName Name.Name - | NoName - - -data Category - = List - | Number - | Float - | String - | Char - | If - | Case - | CallResult MaybeName - | Lambda - | Accessor Name.Name - | Access Name.Name - | Record - | Tuple - | Unit - | Shader - | Effects - | Local Name.Name - | Foreign Name.Name - - - --- PATTERN EXPECTATIONS - - -data PExpected tipe - = PNoExpectation tipe - | PFromContext A.Region PContext tipe - - -data PContext - = PTypedArg Name.Name Index.ZeroBased - | PCaseMatch Index.ZeroBased - | PCtorArg Name.Name Index.ZeroBased - | PListEntry Index.ZeroBased - | PTail - - -data PCategory - = PRecord - | PUnit - | PTuple - | PList - | PCtor Name.Name - | PInt - | PStr - | PChr - | PBool - - - --- HELPERS - - -typeReplace :: Expected a -> b -> Expected b -typeReplace expectation tipe = - case expectation of - NoExpectation _ -> - NoExpectation tipe - - FromContext region context _ -> - FromContext region context tipe - - FromAnnotation name arity context _ -> - FromAnnotation name arity context tipe - - -ptypeReplace :: PExpected a -> b -> PExpected b -ptypeReplace expectation tipe = - case expectation of - PNoExpectation _ -> - PNoExpectation tipe - - PFromContext region context _ -> - PFromContext region context tipe - - - --- TO REPORT - - -toReport :: Code.Source -> L.Localizer -> Error -> Report.Report -toReport source localizer err = - case err of - BadExpr region category actualType expected -> - toExprReport source localizer region category actualType expected - - BadPattern region category tipe expected -> - toPatternReport source localizer region category tipe expected - - InfiniteType region name overallType -> - toInfiniteReport source localizer region name overallType - - - --- TO PATTERN REPORT - - -toPatternReport :: Code.Source -> L.Localizer -> A.Region -> PCategory -> T.Type -> PExpected T.Type -> Report.Report -toPatternReport source localizer patternRegion category tipe expected = - Report.Report "TYPE MISMATCH" patternRegion [] $ - case expected of - PNoExpectation expectedType -> - Code.toSnippet source patternRegion Nothing $ - ( "This pattern is being used in an unexpected way:" - , patternTypeComparison localizer tipe expectedType - (addPatternCategory "It is" category) - "But it needs to match:" - [] - ) - - PFromContext region context expectedType -> - Code.toSnippet source region (Just patternRegion) $ - case context of - PTypedArg name index -> - ( D.reflow $ - "The " <> D.ordinal index <> " argument to `" <> Name.toChars name <> "` is weird." - , patternTypeComparison localizer tipe expectedType - (addPatternCategory "The argument is a pattern that matches" category) - ( "But the type annotation on `" <> Name.toChars name - <> "` says the " <> D.ordinal index <> " argument should be:" - ) - [] - ) - - PCaseMatch index -> - if index == Index.first then - ( - D.reflow $ - "The 1st pattern in this `case` causing a mismatch:" - , - patternTypeComparison localizer tipe expectedType - (addPatternCategory "The first pattern is trying to match" category) - "But the expression between `case` and `of` is:" - [ D.reflow $ - "These can never match! Is the pattern the problem? Or is it the expression?" - ] - ) - else - ( D.reflow $ - "The " <> D.ordinal index <> " pattern in this `case` does not match the previous ones." - , patternTypeComparison localizer tipe expectedType - (addPatternCategory ("The " <> D.ordinal index <> " pattern is trying to match") category) - "But all the previous patterns match:" - [ D.link "Note" - "A `case` expression can only handle one type of value, so you may want to use" - "custom-types" - "to handle “mixing” types." - ] - ) - - PCtorArg name index -> - ( D.reflow $ - "The " <> D.ordinal index <> " argument to `" <> Name.toChars name <> "` is weird." - , patternTypeComparison localizer tipe expectedType - (addPatternCategory "It is trying to match" category) - ( "But `" <> Name.toChars name <> "` needs its " - <> D.ordinal index <> " argument to be:" - ) - [] - ) - - PListEntry index -> - ( D.reflow $ - "The " <> D.ordinal index <> " pattern in this list does not match all the previous ones:" - , patternTypeComparison localizer tipe expectedType - (addPatternCategory ("The " <> D.ordinal index <> " pattern is trying to match") category) - "But all the previous patterns in the list are:" - [ D.link "Hint" - "Everything in a list must be the same type of value. This way, we never\ - \ run into unexpected values partway through a List.map, List.foldl, etc. Read" - "custom-types" - "to learn how to “mix” types." - ] - ) - - PTail -> - ( D.reflow $ - "The pattern after (::) is causing issues." - , patternTypeComparison localizer tipe expectedType - (addPatternCategory "The pattern after (::) is trying to match" category) - "But it needs to match lists like this:" - [] - ) - - - --- PATTERN HELPERS - - -patternTypeComparison :: L.Localizer -> T.Type -> T.Type -> String -> String -> [D.Doc] -> D.Doc -patternTypeComparison localizer actual expected iAmSeeing insteadOf contextHints = - let - (actualDoc, expectedDoc, problems) = - T.toComparison localizer actual expected - in - D.stack $ - [ D.reflow iAmSeeing - , D.indent 4 actualDoc - , D.reflow insteadOf - , D.indent 4 expectedDoc - ] - ++ problemsToHint problems - ++ contextHints - - -addPatternCategory :: String -> PCategory -> String -addPatternCategory iAmTryingToMatch category = - iAmTryingToMatch <> - case category of - PRecord -> " record values of type:" - PUnit -> " unit values:" - PTuple -> " tuples of type:" - PList -> " lists of type:" - PCtor name -> " `" <> Name.toChars name <> "` values of type:" - PInt -> " integers:" - PStr -> " strings:" - PChr -> " characters:" - PBool -> " booleans:" - - - --- EXPR HELPERS - - -typeComparison :: L.Localizer -> T.Type -> T.Type -> String -> String -> [D.Doc] -> D.Doc -typeComparison localizer actual expected iAmSeeing insteadOf contextHints = - let - (actualDoc, expectedDoc, problems) = - T.toComparison localizer actual expected - in - D.stack $ - [ D.reflow iAmSeeing - , D.indent 4 actualDoc - , D.reflow insteadOf - , D.indent 4 expectedDoc - ] - ++ contextHints - ++ problemsToHint problems - - -loneType :: L.Localizer -> T.Type -> T.Type -> D.Doc -> [D.Doc] -> D.Doc -loneType localizer actual expected iAmSeeing furtherDetails = - let - (actualDoc, _, problems) = - T.toComparison localizer actual expected - in - D.stack $ - [ iAmSeeing - , D.indent 4 actualDoc - ] - ++ furtherDetails - ++ problemsToHint problems - - -addCategory :: String -> Category -> String -addCategory thisIs category = - case category of - Local name -> "This `" <> Name.toChars name <> "` value is a:" - Foreign name -> "This `" <> Name.toChars name <> "` value is a:" - Access field -> "The value at ." <> Name.toChars field <> " is a:" - Accessor field -> "This ." <> Name.toChars field <> " field access function has type:" - If -> "This `if` expression produces:" - Case -> "This `case` expression produces:" - List -> thisIs <> " a list of type:" - Number -> thisIs <> " a number of type:" - Float -> thisIs <> " a float of type:" - String -> thisIs <> " a string of type:" - Char -> thisIs <> " a character of type:" - Lambda -> thisIs <> " an anonymous function of type:" - Record -> thisIs <> " a record of type:" - Tuple -> thisIs <> " a tuple of type:" - Unit -> thisIs <> " a unit value:" - Shader -> thisIs <> " a GLSL shader of type:" - Effects -> thisIs <> " a thing for CORE LIBRARIES ONLY." - CallResult maybeName -> - case maybeName of - NoName -> thisIs <> ":" - FuncName name -> "This `" <> Name.toChars name <> "` call produces:" - CtorName name -> "This `" <> Name.toChars name <> "` call produces:" - OpName _ -> thisIs <> ":" - - -problemsToHint :: [T.Problem] -> [D.Doc] -problemsToHint problems = - case problems of - [] -> - [] - - problem : _ -> - problemToHint problem - - -problemToHint :: T.Problem -> [D.Doc] -problemToHint problem = - case problem of - T.IntFloat -> - [ D.fancyLink "Note" ["Read"] "implicit-casts" - ["to","learn","why","Elm","does","not","implicitly","convert" - ,"Ints","to","Floats.","Use",D.green "toFloat","and" - ,D.green "round","to","do","explicit","conversions." - ] - ] - - T.StringFromInt -> - [ D.toFancyHint - ["Want","to","convert","an","Int","into","a","String?" - ,"Use","the",D.green "String.fromInt","function!" - ] - ] - - T.StringFromFloat -> - [ D.toFancyHint - ["Want","to","convert","a","Float","into","a","String?" - ,"Use","the",D.green "String.fromFloat","function!" - ] - ] - - T.StringToInt -> - [ D.toFancyHint - ["Want","to","convert","a","String","into","an","Int?" - ,"Use","the",D.green "String.toInt","function!" - ] - ] - - T.StringToFloat -> - [ D.toFancyHint - ["Want","to","convert","a","String","into","a","Float?" - ,"Use","the",D.green "String.toFloat","function!" - ] - ] - - T.AnythingToBool -> - [ D.toSimpleHint $ - "Elm does not have “truthiness” such that ints and strings and lists\ - \ are automatically converted to booleans. Do that conversion explicitly!" - ] - - T.AnythingFromMaybe -> - [ D.toFancyHint - ["Use",D.green "Maybe.withDefault","to","handle","possible","errors." - ,"Longer","term,","it","is","usually","better","to","write","out","the" - ,"full","`case`","though!" - ] - ] - - T.ArityMismatch x y -> - [ D.toSimpleHint $ - if x < y then - "It looks like it takes too few arguments. I was expecting " ++ show (y - x) ++ " more." - else - "It looks like it takes too many arguments. I see " ++ show (x - y) ++ " extra." - ] - - T.BadFlexSuper direction super _ tipe -> - case tipe of - T.Lambda _ _ _ -> badFlexSuper direction super tipe - T.Infinite -> [] - T.Error -> [] - T.FlexVar _ -> [] - T.FlexSuper s _ -> badFlexFlexSuper super s - T.RigidVar y -> badRigidVar y (toASuperThing super) - T.RigidSuper s _ -> badRigidSuper s (toASuperThing super) - T.Type _ _ _ -> badFlexSuper direction super tipe - T.Record _ _ -> badFlexSuper direction super tipe - T.Unit -> badFlexSuper direction super tipe - T.Tuple _ _ _ -> badFlexSuper direction super tipe - T.Alias _ _ _ _ -> badFlexSuper direction super tipe - - T.BadRigidVar x tipe -> - case tipe of - T.Lambda _ _ _ -> badRigidVar x "a function" - T.Infinite -> [] - T.Error -> [] - T.FlexVar _ -> [] - T.FlexSuper s _ -> badRigidVar x (toASuperThing s) - T.RigidVar y -> badDoubleRigid x y - T.RigidSuper _ y -> badDoubleRigid x y - T.Type _ n _ -> badRigidVar x ("a `" ++ Name.toChars n ++ "` value") - T.Record _ _ -> badRigidVar x "a record" - T.Unit -> badRigidVar x "a unit value" - T.Tuple _ _ _ -> badRigidVar x "a tuple" - T.Alias _ n _ _ -> badRigidVar x ("a `" ++ Name.toChars n ++ "` value") - - T.BadRigidSuper super x tipe -> - case tipe of - T.Lambda _ _ _ -> badRigidSuper super "a function" - T.Infinite -> [] - T.Error -> [] - T.FlexVar _ -> [] - T.FlexSuper s _ -> badRigidSuper super (toASuperThing s) - T.RigidVar y -> badDoubleRigid x y - T.RigidSuper _ y -> badDoubleRigid x y - T.Type _ n _ -> badRigidSuper super ("a `" ++ Name.toChars n ++ "` value") - T.Record _ _ -> badRigidSuper super "a record" - T.Unit -> badRigidSuper super "a unit value" - T.Tuple _ _ _ -> badRigidSuper super "a tuple" - T.Alias _ n _ _ -> badRigidSuper super ("a `" ++ Name.toChars n ++ "` value") - - T.FieldsMissing fields -> - case map (D.green . D.fromName) fields of - [] -> - [] - - [f1] -> - [ D.toFancyHint ["Looks","like","the",f1,"field","is","missing."] - ] - - fieldDocs -> - [ D.toFancyHint $ - ["Looks","like","fields"] ++ D.commaSep "and" id fieldDocs ++ ["are","missing."] - ] - - - T.FieldTypo typo possibilities -> - case Suggest.sort (Name.toChars typo) Name.toChars possibilities of - [] -> - [] - - nearest:_ -> - [ D.toFancyHint $ - ["Seems","like","a","record","field","typo.","Maybe" - ,D.dullyellow (D.fromName typo),"should","be" - ,D.green (D.fromName nearest) <> "?" - ] - , D.toSimpleHint - "Can more type annotations be added? Type annotations always help me give\ - \ more specific messages, and I think they could help a lot in this case!" - ] - - - --- BAD RIGID HINTS - - -badRigidVar :: Name.Name -> String -> [D.Doc] -badRigidVar name aThing = - [ D.toSimpleHint $ - "Your type annotation uses type variable `" ++ Name.toChars name ++ - "` which means ANY type of value can flow through, but your code is saying it specifically wants " - ++ aThing ++ ". Maybe change your type annotation to\ - \ be more specific? Maybe change the code to be more general?" - , D.reflowLink "Read" "type-annotations" "for more advice!" - ] - - -badDoubleRigid :: Name.Name -> Name.Name -> [D.Doc] -badDoubleRigid x y = - [ D.toSimpleHint $ - "Your type annotation uses `" ++ Name.toChars x ++ "` and `" ++ Name.toChars y ++ - "` as separate type variables. Your code seems to be saying they are the\ - \ same though. Maybe they should be the same in your type annotation?\ - \ Maybe your code uses them in a weird way?" - , D.reflowLink "Read" "type-annotations" "for more advice!" - ] - - -toASuperThing :: T.Super -> String -toASuperThing super = - case super of - T.Number -> "a `number` value" - T.Comparable -> "a `comparable` value" - T.CompAppend -> "a `compappend` value" - T.Appendable -> "an `appendable` value" - - - --- BAD SUPER HINTS - - -badFlexSuper :: T.Direction -> T.Super -> T.Type -> [D.Doc] -badFlexSuper direction super tipe = - case super of - T.Comparable -> - case tipe of - T.Record _ _ -> - [ D.link "Hint" - "I do not know how to compare records. I can only compare ints, floats,\ - \ chars, strings, lists of comparable values, and tuples of comparable values.\ - \ Check out" "comparing-records" "for ideas on how to proceed." - ] - - T.Type _ name _ -> - [ D.toSimpleHint $ - "I do not know how to compare `" ++ Name.toChars name ++ "` values. I can only\ - \ compare ints, floats, chars, strings, lists of comparable values, and tuples\ - \ of comparable values." - , D.reflowLink - "Check out" "comparing-custom-types" "for ideas on how to proceed." - ] - - _ -> - [ D.toSimpleHint $ - "I only know how to compare ints, floats, chars, strings, lists of\ - \ comparable values, and tuples of comparable values." - ] - - T.Appendable -> - [ D.toSimpleHint "I only know how to append strings and lists." - ] - - T.CompAppend -> - [ D.toSimpleHint "Only strings and lists are both comparable and appendable." - ] - - T.Number -> - case tipe of - T.Type home name _ | T.isString home name -> - case direction of - T.Have -> - [ D.toFancyHint ["Try","using",D.green "String.fromInt","to","convert","it","to","a","string?"] - ] - - T.Need -> - [ D.toFancyHint ["Try","using",D.green "String.toInt","to","convert","it","to","an","integer?"] - ] - - _ -> - [ D.toFancyHint ["Only",D.green "Int","and",D.green "Float","values","work","as","numbers."] - ] - - -badRigidSuper :: T.Super -> String -> [D.Doc] -badRigidSuper super aThing = - let - (superType, manyThings) = - case super of - T.Number -> ("number", "ints AND floats") - T.Comparable -> ("comparable", "ints, floats, chars, strings, lists, and tuples") - T.Appendable -> ("appendable", "strings AND lists") - T.CompAppend -> ("compappend", "strings AND lists") - in - [ D.toSimpleHint $ - "The `" ++ superType ++ "` in your type annotation is saying that " - ++ manyThings ++ " can flow through, but your code is saying it specifically wants " - ++ aThing ++ ". Maybe change your type annotation to\ - \ be more specific? Maybe change the code to be more general?" - , D.reflowLink "Read" "type-annotations" "for more advice!" - ] - - -badFlexFlexSuper :: T.Super -> T.Super -> [D.Doc] -badFlexFlexSuper s1 s2 = - let - likeThis super = - case super of - T.Number -> "a number" - T.Comparable -> "comparable" - T.CompAppend -> "a compappend" - T.Appendable -> "appendable" - in - [ D.toSimpleHint $ - "There are no values in Elm that are both " - ++ likeThis s1 ++ " and " ++ likeThis s2 ++ "." - ] - - - --- TO EXPR REPORT - - -toExprReport :: Code.Source -> L.Localizer -> A.Region -> Category -> T.Type -> Expected T.Type -> Report.Report -toExprReport source localizer exprRegion category tipe expected = - case expected of - NoExpectation expectedType -> - Report.Report "TYPE MISMATCH" exprRegion [] $ - Code.toSnippet source exprRegion Nothing - ( "This expression is being used in an unexpected way:" - , typeComparison localizer tipe expectedType - (addCategory "It is" category) - "But you are trying to use it as:" - [] - ) - - FromAnnotation name _arity subContext expectedType -> - let - thing = - case subContext of - TypedIfBranch index -> D.ordinal index <> " branch of this `if` expression:" - TypedCaseBranch index -> D.ordinal index <> " branch of this `case` expression:" - TypedBody -> "body of the `" <> Name.toChars name <> "` definition:" - - itIs = - case subContext of - TypedIfBranch index -> "The " <> D.ordinal index <> " branch is" - TypedCaseBranch index -> "The " <> D.ordinal index <> " branch is" - TypedBody -> "The body is" - in - Report.Report "TYPE MISMATCH" exprRegion [] $ - Code.toSnippet source exprRegion Nothing $ - ( D.reflow ("Something is off with the " <> thing) - , typeComparison localizer tipe expectedType - (addCategory itIs category) - ("But the type annotation on `" <> Name.toChars name <> "` says it should be:") - [] - ) - - FromContext region context expectedType -> - let - mismatch (maybeHighlight, problem, thisIs, insteadOf, furtherDetails) = - Report.Report "TYPE MISMATCH" exprRegion [] $ - Code.toSnippet source region maybeHighlight - ( D.reflow problem - , typeComparison localizer tipe expectedType (addCategory thisIs category) insteadOf furtherDetails - ) - - badType (maybeHighlight, problem, thisIs, furtherDetails) = - Report.Report "TYPE MISMATCH" exprRegion [] $ - Code.toSnippet source region maybeHighlight - ( D.reflow problem - , loneType localizer tipe expectedType (D.reflow (addCategory thisIs category)) furtherDetails - ) - - custom maybeHighlight docPair = - Report.Report "TYPE MISMATCH" exprRegion [] $ - Code.toSnippet source region maybeHighlight docPair - in - case context of - ListEntry index -> - let ith = D.ordinal index in - mismatch - ( Just exprRegion - , "The " <> ith <> " element of this list does not match all the previous elements:" - , "The " <> ith <> " element is" - , "But all the previous elements in the list are:" - , [ D.link "Hint" - "Everything in a list must be the same type of value. This way, we never\ - \ run into unexpected values partway through a List.map, List.foldl, etc. Read" - "custom-types" - "to learn how to “mix” types." - ] - ) - - Negate -> - badType - ( Just exprRegion - , "I do not know how to negate this type of value:" - , "It is" - , [ D.fillSep - ["But","I","only","now","how","to","negate" - ,D.dullyellow "Int","and",D.dullyellow "Float","values." - ] - ] - ) - - OpLeft op -> - custom (Just exprRegion) $ - opLeftToDocs localizer category op tipe expectedType - - OpRight op -> - case opRightToDocs localizer category op tipe expectedType of - EmphBoth details -> - custom Nothing details - - EmphRight details -> - custom (Just exprRegion) details - - IfCondition -> - badType - ( Just exprRegion - , "This `if` condition does not evaluate to a boolean value, True or False." - , "It is" - , [ D.fillSep ["But","I","need","this","`if`","condition","to","be","a",D.dullyellow "Bool","value."] - ] - ) - - IfBranch index -> - let ith = D.ordinal index in - mismatch - ( Just exprRegion - , "The " <> ith <> " branch of this `if` does not match all the previous branches:" - , "The " <> ith <> " branch is" - , "But all the previous branches result in:" - , [ D.link "Hint" - "All branches in an `if` must produce the same type of values. This way, no\ - \ matter which branch we take, the result is always a consistent shape. Read" - "custom-types" - "to learn how to “mix” types." - ] - ) - - CaseBranch index -> - let ith = D.ordinal index in - mismatch - ( Just exprRegion - , "The " <> ith <> " branch of this `case` does not match all the previous branches:" - , "The " <> ith <> " branch is" - , "But all the previous branches result in:" - , [ D.link "Hint" - "All branches in a `case` must produce the same type of values. This way, no\ - \ matter which branch we take, the result is always a consistent shape. Read" - "custom-types" - "to learn how to “mix” types." - ] - ) - - CallArity maybeFuncName numGivenArgs -> - Report.Report "TOO MANY ARGS" exprRegion [] $ - Code.toSnippet source region (Just exprRegion) $ - case countArgs tipe of - 0 -> - let - thisValue = - case maybeFuncName of - NoName -> "This value" - FuncName name -> "The `" <> Name.toChars name <> "` value" - CtorName name -> "The `" <> Name.toChars name <> "` value" - OpName op -> "The (" <> Name.toChars op <> ") operator" - in - ( D.reflow $ thisValue <> " is not a function, but it was given " <> D.args numGivenArgs <> "." - , D.reflow $ "Are there any missing commas? Or missing parentheses?" - ) - - n -> - let - thisFunction = - case maybeFuncName of - NoName -> "This function" - FuncName name -> "The `" <> Name.toChars name <> "` function" - CtorName name -> "The `" <> Name.toChars name <> "` constructor" - OpName op -> "The (" <> Name.toChars op <> ") operator" - in - ( D.reflow $ thisFunction <> " expects " <> D.args n <> ", but it got " <> show numGivenArgs <> " instead." - , D.reflow $ "Are there any missing commas? Or missing parentheses?" - ) - - CallArg maybeFuncName index -> - let - ith = D.ordinal index - - thisFunction = - case maybeFuncName of - NoName -> "this function" - FuncName name -> "`" <> Name.toChars name <> "`" - CtorName name -> "`" <> Name.toChars name <> "`" - OpName op -> "(" <> Name.toChars op <> ")" - in - mismatch - ( Just exprRegion - , "The " <> ith <> " argument to " <> thisFunction <> " is not what I expect:" - , "This argument is" - , "But " <> thisFunction <> " needs the " <> ith <> " argument to be:" - , - if Index.toHuman index == 1 then - [] - else - [ D.toSimpleHint $ - "I always figure out the argument types from left to right. If an argument\ - \ is acceptable, I assume it is “correct” and move on. So the problem may\ - \ actually be in one of the previous arguments!" - ] - ) - - RecordAccess recordRegion maybeName fieldRegion field -> - case T.iteratedDealias tipe of - T.Record fields ext -> - custom (Just fieldRegion) - ( D.reflow $ - "This " - <> maybe "" (\n -> "`" <> Name.toChars n <> "`") maybeName - <> " record does not have a `" <> Name.toChars field <> "` field:" - , case Suggest.sort (Name.toChars field) (Name.toChars . fst) (Map.toList fields) of - [] -> - D.reflow "In fact, it is a record with NO fields!" - - f:fs -> - D.stack - [ D.reflow $ - "This is usually a typo. Here are the " - <> maybe "" (\n -> "`" <> Name.toChars n <> "`") maybeName - <> " fields that are most similar:" - , toNearbyRecord localizer f fs ext - , D.fillSep - ["So","maybe",D.dullyellow (D.fromName field) - ,"should","be",D.green (D.fromName (fst f)) <> "?" - ] - ] - ) - - _ -> - badType - ( Just recordRegion - , "This is not a record, so it has no fields to access!" - , "It is" - , [ D.fillSep - ["But","I","need","a","record","with","a" - ,D.dullyellow (D.fromName field),"field!" - ] - ] - ) - - RecordUpdateKeys record expectedFields -> - case T.iteratedDealias tipe of - T.Record actualFields ext -> - case Map.lookupMin (Map.difference expectedFields actualFields) of - Nothing -> - mismatch - ( Nothing - , "Something is off with this record update:" - , "The `" <> Name.toChars record <> "` record is" - , "But this update needs it to be compatable with:" - , [ D.reflow - "Do you mind creating an that produces this error message and\ - \ sharing it at so we\ - \ can try to give better advice here?" - ] - ) - - Just (field, Can.FieldUpdate fieldRegion _) -> - let - rStr = "`" <> Name.toChars record <> "`" - fStr = "`" <> Name.toChars field <> "`" - in - custom (Just fieldRegion) - ( D.reflow $ - "The " <> rStr <> " record does not have a " <> fStr <> " field:" - , case Suggest.sort (Name.toChars field) (Name.toChars . fst) (Map.toList actualFields) of - [] -> - D.reflow $ "In fact, " <> rStr <> " is a record with NO fields!" - - f:fs -> - D.stack - [ D.reflow $ - "This is usually a typo. Here are the " <> rStr <> " fields that are most similar:" - , toNearbyRecord localizer f fs ext - , D.fillSep - ["So","maybe",D.dullyellow (D.fromName field) - ,"should","be",D.green (D.fromName (fst f)) <> "?" - ] - ] - ) - - _ -> - badType - ( Just exprRegion - , "This is not a record, so it has no fields to update!" - , "It is" - , [ D.reflow $ "But I need a record!" - ] - ) - - RecordUpdateValue field -> - mismatch - ( Just exprRegion - , "I cannot update the `" <> Name.toChars field <> "` field like this:" - , "You are trying to update `" <> Name.toChars field <> "` to be" - , "But it should be:" - , [ D.toSimpleNote - "The record update syntax does not allow you to change the type of fields.\ - \ You can achieve that with record constructors or the record literal syntax." - ] - ) - - Destructure -> - mismatch - ( Nothing - , "This definition is causing issues:" - , "You are defining" - , "But then trying to destructure it as:" - , [] - ) - - - --- HELPERS - - -countArgs :: T.Type -> Int -countArgs tipe = - case tipe of - T.Lambda _ _ stuff -> - 1 + length stuff - - _ -> - 0 - - - --- FIELD NAME HELPERS - - -toNearbyRecord :: L.Localizer -> (Name.Name, T.Type) -> [(Name.Name, T.Type)] -> T.Extension -> D.Doc -toNearbyRecord localizer f fs ext = - D.indent 4 $ - if length fs <= 3 then - RT.vrecord (map (fieldToDocs localizer) (f:fs)) (extToDoc ext) - else - RT.vrecordSnippet (fieldToDocs localizer f) (map (fieldToDocs localizer) (take 3 fs)) - - -fieldToDocs :: L.Localizer -> (Name.Name, T.Type) -> (D.Doc, D.Doc) -fieldToDocs localizer (name, tipe) = - ( D.fromName name - , T.toDoc localizer RT.None tipe - ) - - -extToDoc :: T.Extension -> Maybe D.Doc -extToDoc ext = - case ext of - T.Closed -> Nothing - T.FlexOpen x -> Just (D.fromName x) - T.RigidOpen x -> Just (D.fromName x) - - - --- OP LEFT - - -opLeftToDocs :: L.Localizer -> Category -> Name.Name -> T.Type -> T.Type -> (D.Doc, D.Doc) -opLeftToDocs localizer category op tipe expected = - case op of - "+" - | isString tipe -> badStringAdd - | isList tipe -> badListAdd localizer category "left" tipe expected - | otherwise -> badMath localizer category "Addition" "left" "+" tipe expected [] - - "*" - | isList tipe -> badListMul localizer category "left" tipe expected - | otherwise -> badMath localizer category "Multiplication" "left" "*" tipe expected [] - - "-" -> badMath localizer category "Subtraction" "left" "-" tipe expected [] - "^" -> badMath localizer category "Exponentiation" "left" "^" tipe expected [] - "/" -> badFDiv localizer "left" tipe expected - "//" -> badIDiv localizer "left" tipe expected - "&&" -> badBool localizer "&&" "left" tipe expected - "||" -> badBool localizer "||" "left" tipe expected - "<" -> badCompLeft localizer category "<" "left" tipe expected - ">" -> badCompLeft localizer category ">" "left" tipe expected - "<=" -> badCompLeft localizer category "<=" "left" tipe expected - ">=" -> badCompLeft localizer category ">=" "left" tipe expected - - "++" -> badAppendLeft localizer category tipe expected - - "<|" -> - ( "The left side of (<|) needs to be a function so I can pipe arguments to it!" - , loneType localizer tipe expected - (D.reflow (addCategory "I am seeing" category)) - [ D.reflow $ "This needs to be some kind of function though!" - ] - ) - - _ -> - ( D.reflow $ - "The left argument of (" <> Name.toChars op <> ") is causing problems:" - , typeComparison localizer tipe expected - (addCategory "The left argument is" category) - ("But (" <> Name.toChars op <> ") needs the left argument to be:") - [] - ) - - - --- OP RIGHT - - -data RightDocs - = EmphBoth (D.Doc, D.Doc) - | EmphRight (D.Doc, D.Doc) - - -opRightToDocs :: L.Localizer -> Category -> Name.Name -> T.Type -> T.Type -> RightDocs -opRightToDocs localizer category op tipe expected = - case op of - "+" - | isFloat expected && isInt tipe -> badCast op FloatInt - | isInt expected && isFloat tipe -> badCast op IntFloat - | isString tipe -> EmphRight $ badStringAdd - | isList tipe -> EmphRight $ badListAdd localizer category "right" tipe expected - | otherwise -> EmphRight $ badMath localizer category "Addition" "right" "+" tipe expected [] - - "*" - | isFloat expected && isInt tipe -> badCast op FloatInt - | isInt expected && isFloat tipe -> badCast op IntFloat - | isList tipe -> EmphRight $ badListMul localizer category "right" tipe expected - | otherwise -> EmphRight $ badMath localizer category "Multiplication" "right" "*" tipe expected [] - - "-" - | isFloat expected && isInt tipe -> badCast op FloatInt - | isInt expected && isFloat tipe -> badCast op IntFloat - | otherwise -> - EmphRight $ badMath localizer category "Subtraction" "right" "-" tipe expected [] - - "^" - | isFloat expected && isInt tipe -> badCast op FloatInt - | isInt expected && isFloat tipe -> badCast op IntFloat - | otherwise -> - EmphRight $ badMath localizer category "Exponentiation" "right" "^" tipe expected [] - - "/" -> EmphRight $ badFDiv localizer "right" tipe expected - "//" -> EmphRight $ badIDiv localizer "right" tipe expected - "&&" -> EmphRight $ badBool localizer "&&" "right" tipe expected - "||" -> EmphRight $ badBool localizer "||" "right" tipe expected - "<" -> badCompRight localizer "<" tipe expected - ">" -> badCompRight localizer ">" tipe expected - "<=" -> badCompRight localizer "<=" tipe expected - ">=" -> badCompRight localizer ">=" tipe expected - "==" -> badEquality localizer "==" tipe expected - "/=" -> badEquality localizer "/=" tipe expected - - "::" -> badConsRight localizer category tipe expected - "++" -> badAppendRight localizer category tipe expected - - "<|" -> - EmphRight - ( D.reflow $ "I cannot send this through the (<|) pipe:" - , typeComparison localizer tipe expected - "The argument is:" - "But (<|) is piping it to a function that expects:" - [] - ) - - "|>" -> - case (tipe, expected) of - (T.Lambda expectedArgType _ _, T.Lambda argType _ _) -> - EmphRight - ( D.reflow $ "This function cannot handle the argument sent through the (|>) pipe:" - , typeComparison localizer argType expectedArgType - "The argument is:" - "But (|>) is piping it to a function that expects:" - [] - ) - - _ -> - EmphRight - ( D.reflow $ "The right side of (|>) needs to be a function so I can pipe arguments to it!" - , loneType localizer tipe expected - (D.reflow (addCategory "But instead of a function, I am seeing" category)) - [] - ) - - _ -> - badOpRightFallback localizer category op tipe expected - - -badOpRightFallback :: L.Localizer -> Category -> Name.Name -> T.Type -> T.Type -> RightDocs -badOpRightFallback localizer category op tipe expected = - EmphRight - ( D.reflow $ - "The right argument of (" <> Name.toChars op <> ") is causing problems." - , typeComparison localizer tipe expected - (addCategory "The right argument is" category) - ("But (" <> Name.toChars op <> ") needs the right argument to be:") - [ D.toSimpleHint $ - "With operators like (" ++ Name.toChars op ++ ") I always check the left\ - \ side first. If it seems fine, I assume it is correct and check the right\ - \ side. So the problem may be in how the left and right arguments interact!" - ] - ) - - -isInt :: T.Type -> Bool -isInt tipe = - case tipe of - T.Type home name [] -> - T.isInt home name - - _ -> - False - - -isFloat :: T.Type -> Bool -isFloat tipe = - case tipe of - T.Type home name [] -> - T.isFloat home name - - _ -> - False - - -isString :: T.Type -> Bool -isString tipe = - case tipe of - T.Type home name [] -> - T.isString home name - - _ -> - False - - -isList :: T.Type -> Bool -isList tipe = - case tipe of - T.Type home name [_] -> - T.isList home name - - _ -> - False - - - --- BAD CONS - - -badConsRight :: L.Localizer -> Category -> T.Type -> T.Type -> RightDocs -badConsRight localizer category tipe expected = - case tipe of - T.Type home1 name1 [actualElement] | T.isList home1 name1 -> - case expected of - T.Type home2 name2 [expectedElement] | T.isList home2 name2 -> - EmphBoth - ( D.reflow "I am having trouble with this (::) operator:" - , typeComparison localizer expectedElement actualElement - "The left side of (::) is:" - "But you are trying to put that into a list filled with:" - ( case expectedElement of - T.Type home name [_] | T.isList home name -> - [ D.toSimpleHint - "Are you trying to append two lists? The (++) operator\ - \ appends lists, whereas the (::) operator is only for\ - \ adding ONE element to a list." - ] - - _ -> - [ D.reflow - "Lists need ALL elements to be the same type though." - ] - ) - ) - - _ -> - badOpRightFallback localizer category "::" tipe expected - - _ -> - EmphRight - ( D.reflow "The (::) operator can only add elements onto lists." - , loneType localizer tipe expected - (D.reflow (addCategory "The right side is" category)) - [D.fillSep ["But","(::)","needs","a",D.dullyellow "List","on","the","right."] - ] - ) - - - --- BAD APPEND - - -data AppendType - = ANumber D.Doc D.Doc - | AString - | AList - | AOther - - -toAppendType :: T.Type -> AppendType -toAppendType tipe = - case tipe of - T.Type home name _ - | T.isInt home name -> ANumber "Int" "String.fromInt" - | T.isFloat home name -> ANumber "Float" "String.fromFloat" - | T.isString home name -> AString - | T.isList home name -> AList - - T.FlexSuper T.Number _ -> ANumber "number" "String.fromInt" - - _ -> AOther - - -badAppendLeft :: L.Localizer -> Category -> T.Type -> T.Type -> (D.Doc, D.Doc) -badAppendLeft localizer category tipe expected = - case toAppendType tipe of - ANumber thing stringFromThing -> - ( D.fillSep - ["The","(++)","operator","can","append","List","and","String" - ,"values,","but","not",D.dullyellow thing,"values","like","this:" - ] - , D.fillSep - ["Try","using",D.green stringFromThing,"to","turn","it","into","a","string?" - ,"Or","put","it","in","[]","to","make","it","a","list?" - ,"Or","switch","to","the","(::)","operator?" - ] - ) - - _ -> - ( D.reflow $ - "The (++) operator cannot append this type of value:" - , loneType localizer tipe expected - (D.reflow (addCategory "I am seeing" category)) - [ D.fillSep - ["But","the","(++)","operator","is","only","for","appending" - ,D.dullyellow "List","and",D.dullyellow "String","values." - ,"Maybe","put","this","value","in","[]","to","make","it","a","list?" - ] - ] - ) - - -badAppendRight :: L.Localizer -> Category -> T.Type -> T.Type -> RightDocs -badAppendRight localizer category tipe expected = - case (toAppendType expected, toAppendType tipe) of - (AString, ANumber thing stringFromThing) -> - EmphRight - ( D.fillSep - ["I","thought","I","was","appending",D.dullyellow "String","values","here," - ,"not",D.dullyellow thing,"values","like","this:" - ] - , D.fillSep - ["Try","using",D.green stringFromThing,"to","turn","it","into","a","string?"] - ) - - (AList, ANumber thing _) -> - EmphRight - ( D.fillSep - ["I","thought","I","was","appending",D.dullyellow "List","values","here," - ,"not",D.dullyellow thing,"values","like","this:" - ] - , D.reflow "Try putting it in [] to make it a list?" - ) - - (AString, AList) -> - EmphBoth - ( D.reflow $ - "The (++) operator needs the same type of value on both sides:" - , D.fillSep - ["I","see","a",D.dullyellow "String","on","the","left","and","a" - ,D.dullyellow "List","on","the","right.","Which","should","it","be?" - ,"Does","the","string","need","[]","around","it","to","become","a","list?" - ] - ) - - (AList, AString) -> - EmphBoth - ( D.reflow $ - "The (++) operator needs the same type of value on both sides:" - , D.fillSep - ["I","see","a",D.dullyellow "List","on","the","left","and","a" - ,D.dullyellow "String","on","the","right.","Which","should","it","be?" - ,"Does","the","string","need","[]","around","it","to","become","a","list?" - ] - ) - - (_,_) -> - EmphBoth - ( D.reflow $ - "The (++) operator cannot append these two values:" - , typeComparison localizer expected tipe - "I already figured out that the left side of (++) is:" - (addCategory "But this clashes with the right side, which is" category) - [] - ) - - - --- BAD MATH - - -data ThisThenThat = FloatInt | IntFloat - - -badCast :: Name.Name -> ThisThenThat -> RightDocs -badCast op thisThenThat = - EmphBoth - ( D.reflow $ - "I need both sides of (" <> Name.toChars op <> ") to be the exact same type. Both Int or both Float." - , let - anInt = ["an", D.dullyellow "Int"] - aFloat = ["a", D.dullyellow "Float"] - toFloat = D.green "toFloat" - round = D.green "round" - in - case thisThenThat of - FloatInt -> - badCastHelp aFloat anInt round toFloat - - IntFloat -> - badCastHelp anInt aFloat toFloat round - ) - - -badCastHelp :: [D.Doc] -> [D.Doc] -> D.Doc -> D.Doc -> D.Doc -badCastHelp anInt aFloat toFloat round = - D.stack - [ D.fillSep $ - ["But","I","see"] - ++ anInt - ++ ["on","the","left","and"] - ++ aFloat - ++ ["on","the","right."] - , D.fillSep - ["Use",toFloat,"on","the","left","(or",round,"on" - ,"the","right)","to","make","both","sides","match!" - ] - , D.link "Note" "Read" "implicit-casts" "to learn why Elm does not implicitly convert Ints to Floats." - ] - - -badStringAdd :: (D.Doc, D.Doc) -badStringAdd = - ( - D.fillSep ["I","cannot","do","addition","with",D.dullyellow "String","values","like","this","one:"] - , - D.stack - [ D.fillSep - ["The","(+)","operator","only","works","with",D.dullyellow "Int","and",D.dullyellow "Float","values." - ] - , D.toFancyHint - ["Switch","to","the",D.green "(++)","operator","to","append","strings!" - ] - ] - ) - - -badListAdd :: L.Localizer -> Category -> String -> T.Type -> T.Type -> (D.Doc, D.Doc) -badListAdd localizer category direction tipe expected = - ( - "I cannot do addition with lists:" - , - loneType localizer tipe expected - (D.reflow (addCategory ("The " <> direction <> " side of (+) is") category)) - [ D.fillSep - ["But","(+)","only","works","with",D.dullyellow "Int","and",D.dullyellow "Float","values." - ] - , D.toFancyHint - ["Switch","to","the",D.green "(++)","operator","to","append","lists!" - ] - ] - ) - - -badListMul :: L.Localizer -> Category -> String -> T.Type -> T.Type -> (D.Doc, D.Doc) -badListMul localizer category direction tipe expected = - badMath localizer category "Multiplication" direction "*" tipe expected - [ - D.toFancyHint - [ "Maybe", "you", "want" - , D.green "List.repeat" - , "to", "build","a","list","of","repeated","values?" - ] - ] - - -badMath :: L.Localizer -> Category -> String -> String -> String -> T.Type -> T.Type -> [D.Doc] -> (D.Doc, D.Doc) -badMath localizer category operation direction op tipe expected otherHints = - ( - D.reflow $ - operation ++ " does not work with this value:" - , - loneType localizer tipe expected - (D.reflow (addCategory ("The " <> direction <> " side of (" <> op <> ") is") category)) - ( [ D.fillSep - ["But","(" <> D.fromChars op <> ")","only","works","with" - ,D.dullyellow "Int","and",D.dullyellow "Float","values." - ] - ] - ++ otherHints - ) - ) - - -badFDiv :: L.Localizer -> D.Doc -> T.Type -> T.Type -> (D.Doc, D.Doc) -badFDiv localizer direction tipe expected = - ( - D.reflow $ - "The (/) operator is specifically for floating-point division:" - , - if isInt tipe then - D.stack - [ D.fillSep - ["The",direction,"side","of","(/)","must","be","a" - ,D.dullyellow "Float" <> "," - ,"but","I","am","seeing","an",D.dullyellow "Int" <> "." - ,"I","recommend:" - ] - , D.vcat - [ D.green "toFloat" <> " for explicit conversions " <> D.black "(toFloat 5 / 2) == 2.5" - , D.green "(//) " <> " for integer division " <> D.black "(5 // 2) == 2" - ] - , D.link "Note" "Read" "implicit-casts" "to learn why Elm does not implicitly convert Ints to Floats." - ] - - else - loneType localizer tipe expected - (D.fillSep - ["The",direction,"side","of","(/)","must","be","a" - ,D.dullyellow "Float" <> ",","but","instead","I","am","seeing:" - ] - ) - [] - ) - - -badIDiv :: L.Localizer -> D.Doc -> T.Type -> T.Type -> (D.Doc, D.Doc) -badIDiv localizer direction tipe expected = - ( - D.reflow $ - "The (//) operator is specifically for integer division:" - , - if isFloat tipe then - D.stack - [ D.fillSep - ["The",direction,"side","of","(//)","must","be","an" - ,D.dullyellow "Int" <> "," - ,"but","I","am","seeing","a",D.dullyellow "Float" <> "." - ,"I","recommend","doing","the","conversion","explicitly" - ,"with","one","of","these","functions:" - ] - , D.vcat - [ D.green "round" <> " 3.5 == 4" - , D.green "floor" <> " 3.5 == 3" - , D.green "ceiling" <> " 3.5 == 4" - , D.green "truncate" <> " 3.5 == 3" - ] - , D.link "Note" "Read" "implicit-casts" "to learn why Elm does not implicitly convert Ints to Floats." - ] - else - loneType localizer tipe expected - ( D.fillSep - ["The",direction,"side","of","(//)","must","be","an" - ,D.dullyellow "Int" <> ",","but","instead","I","am","seeing:" - ] - ) - [] - ) - - - --- BAD BOOLS - - -badBool :: L.Localizer -> D.Doc -> D.Doc -> T.Type -> T.Type -> (D.Doc, D.Doc) -badBool localizer op direction tipe expected = - ( - D.reflow $ - "I am struggling with this boolean operation:" - , - loneType localizer tipe expected - ( D.fillSep - ["Both","sides","of","(" <> op <> ")","must","be" - ,D.dullyellow "Bool","values,","but","the",direction,"side","is:" - ] - ) - [] - ) - - - --- BAD COMPARISON - - -badCompLeft :: L.Localizer -> Category -> String -> String -> T.Type -> T.Type -> (D.Doc, D.Doc) -badCompLeft localizer category op direction tipe expected = - ( - D.reflow $ - "I cannot do a comparison with this value:" - , - loneType localizer tipe expected - (D.reflow (addCategory ("The " <> direction <> " side of (" <> op <> ") is") category)) - [ D.fillSep - ["But","(" <> D.fromChars op <> ")","only","works","on" - ,D.dullyellow "Int" <> "," - ,D.dullyellow "Float" <> "," - ,D.dullyellow "Char" <> "," - ,"and" - ,D.dullyellow "String" - ,"values.","It","can","work","on","lists","and","tuples" - ,"of","comparable","values","as","well,","but","it","is" - ,"usually","better","to","find","a","different","path." - ] - ] - ) - - -badCompRight :: L.Localizer -> String -> T.Type -> T.Type -> RightDocs -badCompRight localizer op tipe expected = - EmphBoth - ( - D.reflow $ - "I need both sides of (" <> op <> ") to be the same type:" - , - typeComparison localizer expected tipe - ("The left side of (" <> op <> ") is:") - "But the right side is:" - [ D.reflow $ - "I cannot compare different types though! Which side of (" <> op <> ") is the problem?" - ] - ) - - - --- BAD EQUALITY - - -badEquality :: L.Localizer -> String -> T.Type -> T.Type -> RightDocs -badEquality localizer op tipe expected = - EmphBoth - ( - D.reflow $ - "I need both sides of (" <> op <> ") to be the same type:" - , - typeComparison localizer expected tipe - ("The left side of (" <> op <> ") is:") - "But the right side is:" - [ if isFloat tipe || isFloat expected then - D.toSimpleNote $ - "Equality on floats is not 100% reliable due to the design of IEEE 754. I\ - \ recommend a check like (abs (x - y) < 0.0001) instead." - else - D.reflow "Different types can never be equal though! Which side is messed up?" - ] - ) - - - --- INFINITE TYPES - - -toInfiniteReport :: Code.Source -> L.Localizer -> A.Region -> Name.Name -> T.Type -> Report.Report -toInfiniteReport source localizer region name overallType = - Report.Report "INFINITE TYPE" region [] $ - Code.toSnippet source region Nothing - ( - D.reflow $ - "I am inferring a weird self-referential type for " <> Name.toChars name <> ":" - , - D.stack - [ D.reflow $ - "Here is my best effort at writing down the type. You will see ∞ for\ - \ parts of the type that repeat something already printed out infinitely." - , D.indent 4 (D.dullyellow (T.toDoc localizer RT.None overallType)) - , D.reflowLink - "Staring at this type is usually not so helpful, so I recommend reading the hints at" - "infinite-type" - "to get unstuck!" - ] - ) diff --git a/compiler/src/Reporting/Render/Code.hs b/compiler/src/Reporting/Render/Code.hs deleted file mode 100644 index 6be8329a18..0000000000 --- a/compiler/src/Reporting/Render/Code.hs +++ /dev/null @@ -1,288 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE OverloadedStrings #-} -module Reporting.Render.Code - ( Source - , toSource - , toSnippet - , toPair - , Next(..) - , whatIsNext - , nextLineStartsWithKeyword - , nextLineStartsWithCloseCurly - ) - where - - -import qualified Data.ByteString as B -import qualified Data.ByteString.UTF8 as UTF8_BS -import qualified Data.Char as Char -import qualified Data.IntSet as IntSet -import qualified Data.List as List -import qualified Data.Name as Name -import qualified Data.Set as Set -import Data.Word (Word16) - -import qualified Reporting.Annotation as A -import qualified Reporting.Doc as D -import Reporting.Doc (Doc) -import Parse.Primitives (Row, Col) -import Parse.Symbol (binopCharSet) -import Parse.Variable (reservedWords) - - - --- CODE - - -newtype Source = - Source [(Word16, String)] - - -toSource :: B.ByteString -> Source -toSource source = - Source $ zip [1..] $ - lines (UTF8_BS.toString source) ++ [""] - - - --- CODE FORMATTING - - -toSnippet :: Source -> A.Region -> Maybe A.Region -> (D.Doc, D.Doc) -> D.Doc -toSnippet source region highlight (preHint, postHint) = - D.vcat - [ preHint - , "" - , render source region highlight - , postHint - ] - - -toPair :: Source -> A.Region -> A.Region -> (D.Doc, D.Doc) -> (D.Doc, D.Doc, D.Doc) -> D.Doc -toPair source r1 r2 (oneStart, oneEnd) (twoStart, twoMiddle, twoEnd) = - case renderPair source r1 r2 of - OneLine codeDocs -> - D.vcat - [ oneStart - , "" - , codeDocs - , oneEnd - ] - - TwoChunks code1 code2 -> - D.vcat - [ twoStart - , "" - , code1 - , twoMiddle - , "" - , code2 - , twoEnd - ] - - - --- RENDER SNIPPET - - -(|>) :: a -> (a -> b) -> b -(|>) a f = - f a - - -render :: Source -> A.Region -> Maybe A.Region -> Doc -render (Source sourceLines) region@(A.Region (A.Position startLine _) (A.Position endLine _)) maybeSubRegion = - let - relevantLines = - sourceLines - |> drop (fromIntegral (startLine - 1)) - |> take (fromIntegral (1 + endLine - startLine)) - - width = - length (show (fst (last relevantLines))) - - smallerRegion = - maybe region id maybeSubRegion - in - case makeUnderline width endLine smallerRegion of - Nothing -> - drawLines True width smallerRegion relevantLines D.empty - - Just underline -> - drawLines False width smallerRegion relevantLines underline - - -makeUnderline :: Int -> Word16 -> A.Region -> Maybe Doc -makeUnderline width realEndLine (A.Region (A.Position start c1) (A.Position end c2)) = - if start /= end || end < realEndLine then - Nothing - - else - let - spaces = replicate (fromIntegral c1 + width + 1) ' ' - zigzag = replicate (max 1 (fromIntegral (c2 - c1))) '^' - in - Just (D.fromChars spaces <> D.red (D.fromChars zigzag)) - - -drawLines :: Bool -> Int -> A.Region -> [(Word16, String)] -> Doc -> Doc -drawLines addZigZag width (A.Region (A.Position startLine _) (A.Position endLine _)) sourceLines finalLine = - D.vcat $ - map (drawLine addZigZag width startLine endLine) sourceLines - ++ [finalLine] - - -drawLine :: Bool -> Int -> Word16 -> Word16 -> (Word16, String) -> Doc -drawLine addZigZag width startLine endLine (n, line) = - addLineNumber addZigZag width startLine endLine n (D.fromChars line) - - -addLineNumber :: Bool -> Int -> Word16 -> Word16 -> Word16 -> Doc -> Doc -addLineNumber addZigZag width start end n line = - let - number = - show n - - lineNumber = - replicate (width - length number) ' ' ++ number ++ "|" - - spacer = - if addZigZag && start <= n && n <= end then - D.red ">" - else - " " - in - D.fromChars lineNumber <> spacer <> line - - - --- RENDER PAIR - - -data CodePair - = OneLine Doc - | TwoChunks Doc Doc - - -renderPair :: Source -> A.Region -> A.Region -> CodePair -renderPair source@(Source sourceLines) region1 region2 = - let - (A.Region (A.Position startRow1 startCol1) (A.Position endRow1 endCol1)) = region1 - (A.Region (A.Position startRow2 startCol2) (A.Position endRow2 endCol2)) = region2 - in - if startRow1 == endRow1 && endRow1 == startRow2 && startRow2 == endRow2 then - let - lineNumber = show startRow1 - spaces1 = replicate (fromIntegral startCol1 + length lineNumber + 1) ' ' - zigzag1 = replicate (fromIntegral (endCol1 - startCol1)) '^' - spaces2 = replicate (fromIntegral (startCol2 - endCol1)) ' ' - zigzag2 = replicate (fromIntegral (endCol2 - startCol2)) '^' - - (Just line) = List.lookup startRow1 sourceLines - in - OneLine $ - D.vcat - [ D.fromChars lineNumber <> "| " <> D.fromChars line - , D.fromChars spaces1 <> D.red (D.fromChars zigzag1) <> - D.fromChars spaces2 <> D.red (D.fromChars zigzag2) - ] - - else - TwoChunks - (render source region1 Nothing) - (render source region2 Nothing) - - - --- WHAT IS NEXT? - - -data Next - = Keyword [Char] - | Operator [Char] - | Close [Char] Char - | Upper Char [Char] - | Lower Char [Char] - | Other (Maybe Char) - - -whatIsNext :: Source -> Row -> Col -> Next -whatIsNext (Source sourceLines) row col = - case List.lookup row sourceLines of - Nothing -> - Other Nothing - - Just line -> - case drop (fromIntegral col - 1) line of - [] -> - Other Nothing - - c:cs - | Char.isUpper c -> Upper c (takeWhile isInner cs) - | Char.isLower c -> detectKeywords c cs - | isSymbol c -> Operator (c : takeWhile isSymbol cs) - | c == ')' -> Close "parenthesis" ')' - | c == ']' -> Close "square bracket" ']' - | c == '}' -> Close "curly brace" '}' - | otherwise -> Other (Just c) - - -detectKeywords :: Char -> [Char] -> Next -detectKeywords c rest = - let - cs = takeWhile isInner rest - name = c : cs - in - if Set.member (Name.fromChars name) reservedWords - then Keyword name - else Lower c name - - -isInner :: Char -> Bool -isInner char = - Char.isAlphaNum char || char == '_' - - -isSymbol :: Char -> Bool -isSymbol char = - IntSet.member (Char.ord char) binopCharSet - - -startsWithKeyword :: [Char] -> [Char] -> Bool -startsWithKeyword restOfLine keyword = - List.isPrefixOf keyword restOfLine - && - case drop (length keyword) restOfLine of - [] -> - True - - c:_ -> - not (isInner c) - - -nextLineStartsWithKeyword :: [Char] -> Source -> Row -> Maybe (Row, Col) -nextLineStartsWithKeyword keyword (Source sourceLines) row = - case List.lookup (row + 1) sourceLines of - Nothing -> - Nothing - - Just line -> - if startsWithKeyword (dropWhile (==' ') line) keyword then - Just (row + 1, 1 + fromIntegral (length (takeWhile (==' ') line))) - else - Nothing - - -nextLineStartsWithCloseCurly :: Source -> Row -> Maybe (Row, Col) -nextLineStartsWithCloseCurly (Source sourceLines) row = - case List.lookup (row + 1) sourceLines of - Nothing -> - Nothing - - Just line -> - case dropWhile (==' ') line of - '}':_ -> - Just (row + 1, 1 + fromIntegral (length (takeWhile (==' ') line))) - - _ -> - Nothing diff --git a/compiler/src/Reporting/Render/Type.hs b/compiler/src/Reporting/Render/Type.hs deleted file mode 100644 index 4433d72c96..0000000000 --- a/compiler/src/Reporting/Render/Type.hs +++ /dev/null @@ -1,257 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE OverloadedStrings #-} -module Reporting.Render.Type - ( Context(..) - , lambda - , apply - , tuple - , record - , vrecordSnippet - , vrecord - , srcToDoc - , canToDoc - ) - where - - -import qualified Data.Maybe as Maybe -import qualified Data.Name as Name - -import qualified AST.Source as Src -import qualified AST.Canonical as Can -import qualified Reporting.Annotation as A -import qualified Reporting.Doc as D -import Reporting.Doc ( Doc, (<+>), (<>) ) -import qualified Reporting.Render.Type.Localizer as L - - - --- TO DOC - - -data Context - = None - | Func - | App - - -lambda :: Context -> Doc -> Doc -> [Doc] -> Doc -lambda context arg1 arg2 args = - let - lambdaDoc = - D.align $ D.sep (arg1 : map ("->" <+>) (arg2:args)) - in - case context of - None -> lambdaDoc - Func -> D.cat [ "(", lambdaDoc, ")" ] - App -> D.cat [ "(", lambdaDoc, ")" ] - - -apply :: Context -> Doc -> [Doc] -> Doc -apply context name args = - case args of - [] -> - name - - _:_ -> - let - applyDoc = - D.hang 4 (D.sep (name : args)) - in - case context of - App -> D.cat [ "(", applyDoc, ")" ] - Func -> applyDoc - None -> applyDoc - - -tuple :: Doc -> Doc -> [Doc] -> Doc -tuple a b cs = - let - entries = - zipWith (<+>) ("(" : repeat ",") (a:b:cs) - in - D.align $ D.sep [ D.cat entries, ")" ] - - -record :: [(Doc, Doc)] -> Maybe Doc -> Doc -record entries maybeExt = - case (map entryToDoc entries, maybeExt) of - ([], Nothing) -> - "{}" - - (fields, Nothing) -> - D.align $ D.sep $ - [ D.cat (zipWith (<+>) ("{" : repeat ",") fields) - , "}" - ] - - (fields, Just ext) -> - D.align $ D.sep $ - [ D.hang 4 $ D.sep $ - [ "{" <+> ext - , D.cat (zipWith (<+>) ("|" : repeat ",") fields) - ] - , "}" - ] - - -entryToDoc :: (Doc, Doc) -> Doc -entryToDoc (fieldName, fieldType) = - D.hang 4 (D.sep [ fieldName <+> ":", fieldType ]) - - -vrecordSnippet :: (Doc, Doc) -> [(Doc, Doc)] -> Doc -vrecordSnippet entry entries = - let - field = "{" <+> entryToDoc entry - fields = zipWith (<+>) (repeat ",") (map entryToDoc entries ++ ["..."]) - in - D.vcat (field : fields ++ ["}"]) - - -vrecord :: [(Doc, Doc)] -> Maybe Doc -> Doc -vrecord entries maybeExt = - case (map entryToDoc entries, maybeExt) of - ([], Nothing) -> - "{}" - - (fields, Nothing) -> - D.vcat $ - zipWith (<+>) ("{" : repeat ",") fields ++ ["}"] - - (fields, Just ext) -> - D.vcat - [ D.hang 4 $ D.vcat $ - [ "{" <+> ext - , D.cat (zipWith (<+>) ("|" : repeat ",") fields) - ] - , "}" - ] - - - --- SOURCE TYPE TO DOC - - -srcToDoc :: Context -> Src.Type -> Doc -srcToDoc context (A.At _ tipe) = - case tipe of - Src.TLambda arg1 result -> - let - (arg2, rest) = collectSrcArgs result - in - lambda context - (srcToDoc Func arg1) - (srcToDoc Func arg2) - (map (srcToDoc Func) rest) - - Src.TVar name -> - D.fromName name - - Src.TType _ name args -> - apply context - (D.fromName name) - (map (srcToDoc App) args) - - Src.TTypeQual _ home name args -> - apply context - (D.fromName home <> "." <> D.fromName name) - (map (srcToDoc App) args) - - Src.TRecord fields ext -> - record - (map srcFieldToDocs fields) - (fmap (D.fromName . A.toValue) ext) - - Src.TUnit -> - "()" - - Src.TTuple a b cs -> - tuple - (srcToDoc None a) - (srcToDoc None b) - (map (srcToDoc None) cs) - - -srcFieldToDocs :: (A.Located Name.Name, Src.Type) -> (Doc, Doc) -srcFieldToDocs (A.At _ fieldName, fieldType) = - ( D.fromName fieldName - , srcToDoc None fieldType - ) - - -collectSrcArgs :: Src.Type -> (Src.Type, [Src.Type]) -collectSrcArgs tipe = - case tipe of - A.At _ (Src.TLambda a result) -> - let - (b, cs) = collectSrcArgs result - in - (a, b:cs) - - _ -> - (tipe, []) - - - --- CANONICAL TYPE TO DOC - - -canToDoc :: L.Localizer -> Context -> Can.Type -> Doc -canToDoc localizer context tipe = - case tipe of - Can.TLambda arg1 result -> - let - (arg2, rest) = collectArgs result - in - lambda context - (canToDoc localizer Func arg1) - (canToDoc localizer Func arg2) - (map (canToDoc localizer Func) rest) - - Can.TVar name -> - D.fromName name - - Can.TType home name args -> - apply context - (L.toDoc localizer home name) - (map (canToDoc localizer App) args) - - Can.TRecord fields ext -> - record - (map (canFieldToDoc localizer) (Can.fieldsToList fields)) - (fmap D.fromName ext) - - Can.TUnit -> - "()" - - Can.TTuple a b maybeC -> - tuple - (canToDoc localizer None a) - (canToDoc localizer None b) - (map (canToDoc localizer None) (Maybe.maybeToList maybeC)) - - Can.TAlias home name args _ -> - apply context - (L.toDoc localizer home name) - (map (canToDoc localizer App . snd) args) - - -canFieldToDoc :: L.Localizer -> (Name.Name, Can.Type) -> (Doc, Doc) -canFieldToDoc localizer (name, tipe) = - ( D.fromName name - , canToDoc localizer None tipe - ) - - -collectArgs :: Can.Type -> (Can.Type, [Can.Type]) -collectArgs tipe = - case tipe of - Can.TLambda a rest -> - let - (b, cs) = collectArgs rest - in - (a, b:cs) - - _ -> - (tipe, []) diff --git a/compiler/src/Reporting/Render/Type/Localizer.hs b/compiler/src/Reporting/Render/Type/Localizer.hs deleted file mode 100644 index aa5956d8b2..0000000000 --- a/compiler/src/Reporting/Render/Type/Localizer.hs +++ /dev/null @@ -1,120 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE OverloadedStrings #-} -module Reporting.Render.Type.Localizer - ( Localizer - , toDoc - , toChars - , empty - , fromNames - , fromModule - ) - where - - -import qualified Data.Map as Map -import qualified Data.Name as Name -import qualified Data.Set as Set - -import qualified AST.Source as Src -import qualified Elm.ModuleName as ModuleName -import Reporting.Doc ((<>)) -import qualified Reporting.Doc as D -import qualified Reporting.Annotation as A - - - --- LOCALIZER - - -newtype Localizer = - Localizer (Map.Map Name.Name Import) - - -data Import = - Import - { _alias :: Maybe Name.Name - , _exposing :: Exposing - } - - -data Exposing - = All - | Only (Set.Set Name.Name) - - -empty :: Localizer -empty = - Localizer Map.empty - - - --- LOCALIZE - - -toDoc :: Localizer -> ModuleName.Canonical -> Name.Name -> D.Doc -toDoc localizer home name = - D.fromChars (toChars localizer home name) - - -toChars :: Localizer -> ModuleName.Canonical -> Name.Name -> String -toChars (Localizer localizer) moduleName@(ModuleName.Canonical _ home) name = - case Map.lookup home localizer of - Nothing -> - Name.toChars home <> "." <> Name.toChars name - - Just (Import alias exposing) -> - case exposing of - All -> - Name.toChars name - - Only set -> - if Set.member name set then - Name.toChars name - else if name == Name.list && moduleName == ModuleName.list then - "List" - else - Name.toChars (maybe home id alias) <> "." <> Name.toChars name - - - --- FROM NAMES - - -fromNames :: Map.Map Name.Name a -> Localizer -fromNames names = - Localizer $ Map.map (\_ -> Import Nothing All) names - - - --- FROM MODULE - - -fromModule :: Src.Module -> Localizer -fromModule modul@(Src.Module _ _ _ imports _ _ _ _ _) = - Localizer $ Map.fromList $ - (Src.getName modul, Import Nothing All) : map toPair imports - - -toPair :: Src.Import -> (Name.Name, Import) -toPair (Src.Import (A.At _ name) alias exposing) = - ( name - , Import alias (toExposing exposing) - ) - - -toExposing :: Src.Exposing -> Exposing -toExposing exposing = - case exposing of - Src.Open -> - All - - Src.Explicit exposedList -> - Only (foldr addType Set.empty exposedList) - - -addType :: Src.Exposed -> Set.Set Name.Name -> Set.Set Name.Name -addType exposed types = - case exposed of - Src.Lower _ -> types - Src.Upper (A.At _ name) _ -> Set.insert name types - Src.Operator _ _ -> types diff --git a/compiler/src/Reporting/Report.hs b/compiler/src/Reporting/Report.hs deleted file mode 100644 index a166607f84..0000000000 --- a/compiler/src/Reporting/Report.hs +++ /dev/null @@ -1,22 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module Reporting.Report - ( Report(..) - ) - where - - -import qualified Reporting.Annotation as A -import qualified Reporting.Doc as D - - - --- BUILD REPORTS - - -data Report = - Report - { _title :: String - , _region :: A.Region - , _sgstns :: [String] - , _message :: D.Doc - } diff --git a/compiler/src/Reporting/Result.hs b/compiler/src/Reporting/Result.hs deleted file mode 100644 index acb6b47182..0000000000 --- a/compiler/src/Reporting/Result.hs +++ /dev/null @@ -1,129 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE Rank2Types #-} -module Reporting.Result - ( Result(..) - , run - , ok - , warn - , throw - , mapError - ) - where - - -import qualified Data.OneOrMore as OneOrMore -import qualified Reporting.Warning as Warning - - - --- RESULT - - -newtype Result info warnings error a = - Result ( - forall result. - info - -> warnings - -> (info -> warnings -> OneOrMore.OneOrMore error -> result) - -> (info -> warnings -> a -> result) - -> result - ) - - -run :: Result () [w] e a -> ([w], Either (OneOrMore.OneOrMore e) a) -run (Result k) = - k () [] - (\() w e -> (reverse w, Left e)) - (\() w a -> (reverse w, Right a)) - - - --- HELPERS - - -ok :: a -> Result i w e a -ok a = - Result $ \i w _ good -> - good i w a - - -warn :: Warning.Warning -> Result i [Warning.Warning] e () -warn warning = - Result $ \i warnings _ good -> - good i (warning:warnings) () - - -throw :: e -> Result i w e a -throw e = - Result $ \i w bad _ -> - bad i w (OneOrMore.one e) - - -mapError :: (e -> e') -> Result i w e a -> Result i w e' a -mapError func (Result k) = - Result $ \i w bad good -> - let - bad1 i1 w1 e1 = - bad i1 w1 (OneOrMore.map func e1) - in - k i w bad1 good - - - --- FANCY INSTANCE STUFF - - -instance Functor (Result i w e) where - fmap func (Result k) = - Result $ \i w bad good -> - let - good1 i1 w1 value = - good i1 w1 (func value) - in - k i w bad good1 - - -instance Applicative (Result i w e) where - pure = ok - - (<*>) (Result kf) (Result kv) = - Result $ \i w bad good -> - let - bad1 i1 w1 e1 = - let - bad2 i2 w2 e2 = bad i2 w2 (OneOrMore.more e1 e2) - good2 i2 w2 _value = bad i2 w2 e1 - in - kv i1 w1 bad2 good2 - - good1 i1 w1 func = - let - bad2 i2 w2 e2 = bad i2 w2 e2 - good2 i2 w2 value = good i2 w2 (func value) - in - kv i1 w1 bad2 good2 - in - kf i w bad1 good1 - - -instance Monad (Result i w e) where - return = ok - - (>>=) (Result ka) callback = - Result $ \i w bad good -> - let - good1 i1 w1 a = - case callback a of - Result kb -> kb i1 w1 bad good - in - ka i w bad good1 - - (>>) (Result ka) (Result kb) = - Result $ \i w bad good -> - let - good1 i1 w1 _ = - kb i1 w1 bad good - in - ka i w bad good1 - - -- PERF add INLINE to these? diff --git a/compiler/src/Reporting/Suggest.hs b/compiler/src/Reporting/Suggest.hs deleted file mode 100644 index e763d2e306..0000000000 --- a/compiler/src/Reporting/Suggest.hs +++ /dev/null @@ -1,52 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE OverloadedStrings #-} -module Reporting.Suggest - ( distance - , sort - , rank - ) - where - - -import qualified Data.Char as Char -import qualified Data.List as List -import qualified Text.EditDistance as Dist - - - --- DISTANCE - - -distance :: String -> String -> Int -distance x y = - Dist.restrictedDamerauLevenshteinDistance Dist.defaultEditCosts x y - - - --- SORT - - -sort :: String -> (a -> String) -> [a] -> [a] -sort target toString values = - List.sortOn (distance (toLower target) . toLower . toString) values - - -toLower :: String -> String -toLower string = - map Char.toLower string - - - --- RANK - - -rank :: String -> (a -> String) -> [a] -> [(Int,a)] -rank target toString values = - let - toRank v = - distance (toLower target) (toLower (toString v)) - - addRank v = - (toRank v, v) - in - List.sortOn fst (map addRank values) diff --git a/compiler/src/Reporting/Warning.hs b/compiler/src/Reporting/Warning.hs deleted file mode 100644 index dc69601401..0000000000 --- a/compiler/src/Reporting/Warning.hs +++ /dev/null @@ -1,104 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE OverloadedStrings #-} -module Reporting.Warning - ( Warning(..) - , Context(..) - , toReport - ) - where - - -import Data.Monoid ((<>)) -import qualified Data.Name as Name - -import qualified AST.Canonical as Can -import qualified AST.Utils.Type as Type -import qualified Reporting.Annotation as A -import qualified Reporting.Doc as D -import qualified Reporting.Report as Report -import qualified Reporting.Render.Code as Code -import qualified Reporting.Render.Type as RT -import qualified Reporting.Render.Type.Localizer as L - - - --- ALL POSSIBLE WARNINGS - - -data Warning - = UnusedImport A.Region Name.Name - | UnusedVariable A.Region Context Name.Name - | MissingTypeAnnotation A.Region Name.Name Can.Type - - -data Context = Def | Pattern - - - --- TO REPORT - - -toReport :: L.Localizer -> Code.Source -> Warning -> Report.Report -toReport localizer source warning = - case warning of - UnusedImport region moduleName -> - Report.Report "unused import" region [] $ - Code.toSnippet source region Nothing - ( - D.reflow $ - "Nothing from the `" <> Name.toChars moduleName <> "` module is used in this file." - , - "I recommend removing unused imports." - ) - - UnusedVariable region context name -> - let title = defOrPat context "unused definition" "unused variable" in - Report.Report title region [] $ - Code.toSnippet source region Nothing - ( - D.reflow $ - "You are not using `" <> Name.toChars name <> "` anywhere." - , - D.stack - [ D.reflow $ - "Is there a typo? Maybe you intended to use `" <> Name.toChars name - <> "` somewhere but typed another name instead?" - , D.reflow $ - defOrPat context - ( "If you are sure there is no typo, remove the definition.\ - \ This way future readers will not have to wonder why it is there!" - ) - ( "If you are sure there is no typo, replace `" <> Name.toChars name - <> "` with _ so future readers will not have to wonder why it is there!" - ) - ] - ) - - MissingTypeAnnotation region name inferredType -> - Report.Report "missing type annotation" region [] $ - Code.toSnippet source region Nothing - ( - D.reflow $ - case Type.deepDealias inferredType of - Can.TLambda _ _ -> - "The `" <> Name.toChars name <> "` function has no type annotation." - - _ -> - "The `" <> Name.toChars name <> "` definition has no type annotation." - , - D.stack - [ "I inferred the type annotation myself though! You can copy it into your code:" - , D.green $ D.hang 4 $ D.sep $ - [ D.fromName name <> " :" - , RT.canToDoc localizer RT.None inferredType - ] - ] - ) - - -defOrPat :: Context -> a -> a -> a -defOrPat context def pat = - case context of - Def -> def - Pattern -> pat - diff --git a/compiler/src/Type/Constrain/Expression.hs b/compiler/src/Type/Constrain/Expression.hs deleted file mode 100644 index 9861245a94..0000000000 --- a/compiler/src/Type/Constrain/Expression.hs +++ /dev/null @@ -1,746 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -module Type.Constrain.Expression - ( constrain - , constrainDef - , constrainRecursiveDefs - ) - where - - -import qualified Data.Map.Strict as Map -import qualified Data.Name as Name - -import qualified AST.Canonical as Can -import qualified AST.Utils.Shader as Shader -import qualified Data.Index as Index -import qualified Elm.ModuleName as ModuleName -import qualified Reporting.Annotation as A -import qualified Reporting.Error.Type as E -import Reporting.Error.Type (Expected(..), Context(..), SubContext(..), MaybeName(..), Category(..), PExpected(..), PContext(..)) -import qualified Type.Constrain.Pattern as Pattern -import qualified Type.Instantiate as Instantiate -import Type.Type as Type hiding (Descriptor(..)) - - - --- CONSTRAIN - - --- As we step past type annotations, the free type variables are added to --- the "rigid type variables" dict. Allowing sharing of rigid variables --- between nested type annotations. --- --- So if you have a top-level type annotation like (func : a -> b) the RTV --- dictionary will hold variables for `a` and `b` --- -type RTV = - Map.Map Name.Name Type - - -constrain :: RTV -> Can.Expr -> Expected Type -> IO Constraint -constrain rtv (A.At region expression) expected = - case expression of - Can.VarLocal name -> - return (CLocal region name expected) - - Can.VarTopLevel _ name -> - return (CLocal region name expected) - - Can.VarKernel _ _ -> - return CTrue - - Can.VarForeign _ name annotation -> - return $ CForeign region name annotation expected - - Can.VarCtor _ _ name _ annotation -> - return $ CForeign region name annotation expected - - Can.VarDebug _ name annotation -> - return $ CForeign region name annotation expected - - Can.VarOperator op _ _ annotation -> - return $ CForeign region op annotation expected - - Can.Str _ -> - return $ CEqual region String Type.string expected - - Can.Chr _ -> - return $ CEqual region Char Type.char expected - - Can.Int _ -> - do var <- mkFlexNumber - return $ exists [var] $ CEqual region E.Number (VarN var) expected - - Can.Float _ -> - return $ CEqual region Float Type.float expected - - Can.List elements -> - constrainList rtv region elements expected - - Can.Negate expr -> - do numberVar <- mkFlexNumber - let numberType = VarN numberVar - numberCon <- constrain rtv expr (FromContext region Negate numberType) - let negateCon = CEqual region E.Number numberType expected - return $ exists [numberVar] $ CAnd [ numberCon, negateCon ] - - Can.Binop op _ _ annotation leftExpr rightExpr -> - constrainBinop rtv region op annotation leftExpr rightExpr expected - - Can.Lambda args body -> - constrainLambda rtv region args body expected - - Can.Call func args -> - constrainCall rtv region func args expected - - Can.If branches finally -> - constrainIf rtv region branches finally expected - - Can.Case expr branches -> - constrainCase rtv region expr branches expected - - Can.Let def body -> - constrainDef rtv def - =<< constrain rtv body expected - - Can.LetRec defs body -> - constrainRecursiveDefs rtv defs - =<< constrain rtv body expected - - Can.LetDestruct pattern expr body -> - constrainDestruct rtv region pattern expr - =<< constrain rtv body expected - - Can.Accessor field -> - do extVar <- mkFlexVar - fieldVar <- mkFlexVar - let extType = VarN extVar - let fieldType = VarN fieldVar - let recordType = RecordN (Map.singleton field fieldType) extType - return $ exists [ fieldVar, extVar ] $ - CEqual region (Accessor field) (FunN recordType fieldType) expected - - Can.Access expr (A.At accessRegion field) -> - do extVar <- mkFlexVar - fieldVar <- mkFlexVar - let extType = VarN extVar - let fieldType = VarN fieldVar - let recordType = RecordN (Map.singleton field fieldType) extType - - let context = RecordAccess (A.toRegion expr) (getAccessName expr) accessRegion field - recordCon <- constrain rtv expr (FromContext region context recordType) - - return $ exists [ fieldVar, extVar ] $ - CAnd - [ recordCon - , CEqual region (Access field) fieldType expected - ] - - Can.Update name expr fields -> - constrainUpdate rtv region name expr fields expected - - Can.Record fields -> - constrainRecord rtv region fields expected - - Can.Unit -> - return $ CEqual region Unit UnitN expected - - Can.Tuple a b maybeC -> - constrainTuple rtv region a b maybeC expected - - Can.Shader _src types -> - constrainShader region types expected - - - --- CONSTRAIN LAMBDA - - -constrainLambda :: RTV -> A.Region -> [Can.Pattern] -> Can.Expr -> Expected Type -> IO Constraint -constrainLambda rtv region args body expected = - do (Args vars tipe resultType (Pattern.State headers pvars revCons)) <- - constrainArgs args - - bodyCon <- - constrain rtv body (NoExpectation resultType) - - return $ exists vars $ - CAnd - [ CLet - { _rigidVars = [] - , _flexVars = pvars - , _header = headers - , _headerCon = CAnd (reverse revCons) - , _bodyCon = bodyCon - } - , CEqual region Lambda tipe expected - ] - - - --- CONSTRAIN CALL - - -constrainCall :: RTV -> A.Region -> Can.Expr -> [Can.Expr] -> Expected Type -> IO Constraint -constrainCall rtv region func@(A.At funcRegion _) args expected = - do let maybeName = getName func - - funcVar <- mkFlexVar - resultVar <- mkFlexVar - let funcType = VarN funcVar - let resultType = VarN resultVar - - funcCon <- constrain rtv func (NoExpectation funcType) - - (argVars, argTypes, argCons) <- - unzip3 <$> Index.indexedTraverse (constrainArg rtv region maybeName) args - - let arityType = foldr FunN resultType argTypes - let category = CallResult maybeName - - return $ exists (funcVar:resultVar:argVars) $ - CAnd - [ funcCon - , CEqual funcRegion category funcType (FromContext region (CallArity maybeName (length args)) arityType) - , CAnd argCons - , CEqual region category resultType expected - ] - - -constrainArg :: RTV -> A.Region -> MaybeName -> Index.ZeroBased -> Can.Expr -> IO (Variable, Type, Constraint) -constrainArg rtv region maybeName index arg = - do argVar <- mkFlexVar - let argType = VarN argVar - argCon <- constrain rtv arg (FromContext region (CallArg maybeName index) argType) - return (argVar, argType, argCon) - - -getName :: Can.Expr -> MaybeName -getName (A.At _ expr) = - case expr of - Can.VarLocal name -> FuncName name - Can.VarTopLevel _ name -> FuncName name - Can.VarForeign _ name _ -> FuncName name - Can.VarCtor _ _ name _ _ -> CtorName name - Can.VarOperator op _ _ _ -> OpName op - Can.VarKernel _ name -> FuncName name - _ -> NoName - - -getAccessName :: Can.Expr -> Maybe Name.Name -getAccessName (A.At _ expr) = - case expr of - Can.VarLocal name -> Just name - Can.VarTopLevel _ name -> Just name - Can.VarForeign _ name _ -> Just name - _ -> Nothing - - - --- CONSTRAIN BINOP - - -constrainBinop :: RTV -> A.Region -> Name.Name -> Can.Annotation -> Can.Expr -> Can.Expr -> Expected Type -> IO Constraint -constrainBinop rtv region op annotation leftExpr rightExpr expected = - do leftVar <- mkFlexVar - rightVar <- mkFlexVar - answerVar <- mkFlexVar - let leftType = VarN leftVar - let rightType = VarN rightVar - let answerType = VarN answerVar - let binopType = leftType ==> rightType ==> answerType - - let opCon = CForeign region op annotation (NoExpectation binopType) - - leftCon <- constrain rtv leftExpr (FromContext region (OpLeft op) leftType) - rightCon <- constrain rtv rightExpr (FromContext region (OpRight op) rightType) - - return $ exists [ leftVar, rightVar, answerVar ] $ - CAnd - [ opCon - , leftCon - , rightCon - , CEqual region (CallResult (OpName op)) answerType expected - ] - - - --- CONSTRAIN LISTS - - -constrainList :: RTV -> A.Region -> [Can.Expr] -> Expected Type -> IO Constraint -constrainList rtv region entries expected = - do entryVar <- mkFlexVar - let entryType = VarN entryVar - let listType = AppN ModuleName.list Name.list [entryType] - - entryCons <- - Index.indexedTraverse (constrainListEntry rtv region entryType) entries - - return $ exists [entryVar] $ - CAnd - [ CAnd entryCons - , CEqual region List listType expected - ] - - -constrainListEntry :: RTV -> A.Region -> Type -> Index.ZeroBased -> Can.Expr -> IO Constraint -constrainListEntry rtv region tipe index expr = - constrain rtv expr (FromContext region (ListEntry index) tipe) - - - --- CONSTRAIN IF EXPRESSIONS - - -constrainIf :: RTV -> A.Region -> [(Can.Expr, Can.Expr)] -> Can.Expr -> Expected Type -> IO Constraint -constrainIf rtv region branches final expected = - do let boolExpect = FromContext region IfCondition Type.bool - let (conditions, exprs) = foldr (\(c,e) (cs,es) -> (c:cs,e:es)) ([],[final]) branches - - condCons <- - traverse (\c -> constrain rtv c boolExpect) conditions - - case expected of - FromAnnotation name arity _ tipe -> - do branchCons <- Index.indexedForA exprs $ \index expr -> - constrain rtv expr (FromAnnotation name arity (TypedIfBranch index) tipe) - return $ - CAnd - [ CAnd condCons - , CAnd branchCons - ] - - _ -> - do branchVar <- mkFlexVar - let branchType = VarN branchVar - - branchCons <- Index.indexedForA exprs $ \index expr -> - constrain rtv expr (FromContext region (IfBranch index) branchType) - - return $ exists [branchVar] $ - CAnd - [ CAnd condCons - , CAnd branchCons - , CEqual region If branchType expected - ] - - - --- CONSTRAIN CASE EXPRESSIONS - - -constrainCase :: RTV -> A.Region -> Can.Expr -> [Can.CaseBranch] -> Expected Type -> IO Constraint -constrainCase rtv region expr branches expected = - do ptrnVar <- mkFlexVar - let ptrnType = VarN ptrnVar - exprCon <- constrain rtv expr (NoExpectation ptrnType) - - case expected of - FromAnnotation name arity _ tipe -> - do branchCons <- Index.indexedForA branches $ \index branch -> - constrainCaseBranch rtv branch - (PFromContext region (PCaseMatch index) ptrnType) - (FromAnnotation name arity (TypedCaseBranch index) tipe) - - return $ exists [ptrnVar] $ CAnd (exprCon:branchCons) - - _ -> - do branchVar <- mkFlexVar - let branchType = VarN branchVar - - branchCons <- Index.indexedForA branches $ \index branch -> - constrainCaseBranch rtv branch - (PFromContext region (PCaseMatch index) ptrnType) - (FromContext region (CaseBranch index) branchType) - - return $ exists [ptrnVar,branchVar] $ - CAnd - [ exprCon - , CAnd branchCons - , CEqual region Case branchType expected - ] - - -constrainCaseBranch :: RTV -> Can.CaseBranch -> PExpected Type -> Expected Type -> IO Constraint -constrainCaseBranch rtv (Can.CaseBranch pattern expr) pExpect bExpect = - do (Pattern.State headers pvars revCons) <- - Pattern.add pattern pExpect Pattern.emptyState - - CLet [] pvars headers (CAnd (reverse revCons)) - <$> constrain rtv expr bExpect - - - --- CONSTRAIN RECORD - - -constrainRecord :: RTV -> A.Region -> Map.Map Name.Name Can.Expr -> Expected Type -> IO Constraint -constrainRecord rtv region fields expected = - do dict <- traverse (constrainField rtv) fields - - let getType (_, t, _) = t - let recordType = RecordN (Map.map getType dict) EmptyRecordN - let recordCon = CEqual region Record recordType expected - - let vars = Map.foldr (\(v,_,_) vs -> v:vs) [] dict - let cons = Map.foldr (\(_,_,c) cs -> c:cs) [recordCon] dict - - return $ exists vars (CAnd cons) - - -constrainField :: RTV -> Can.Expr -> IO (Variable, Type, Constraint) -constrainField rtv expr = - do var <- mkFlexVar - let tipe = VarN var - con <- constrain rtv expr (NoExpectation tipe) - return (var, tipe, con) - - - --- CONSTRAIN RECORD UPDATE - - -constrainUpdate :: RTV -> A.Region -> Name.Name -> Can.Expr -> Map.Map Name.Name Can.FieldUpdate -> Expected Type -> IO Constraint -constrainUpdate rtv region name expr fields expected = - do extVar <- mkFlexVar - fieldDict <- Map.traverseWithKey (constrainUpdateField rtv region) fields - - recordVar <- mkFlexVar - let recordType = VarN recordVar - let fieldsType = RecordN (Map.map (\(_,t,_) -> t) fieldDict) (VarN extVar) - - -- NOTE: fieldsType is separate so that Error propagates better - let fieldsCon = CEqual region Record recordType (NoExpectation fieldsType) - let recordCon = CEqual region Record recordType expected - - let vars = Map.foldr (\(v,_,_) vs -> v:vs) [recordVar,extVar] fieldDict - let cons = Map.foldr (\(_,_,c) cs -> c:cs) [recordCon] fieldDict - - con <- constrain rtv expr (FromContext region (RecordUpdateKeys name fields) recordType) - - return $ exists vars $ CAnd (fieldsCon:con:cons) - - -constrainUpdateField :: RTV -> A.Region -> Name.Name -> Can.FieldUpdate -> IO (Variable, Type, Constraint) -constrainUpdateField rtv region field (Can.FieldUpdate _ expr) = - do var <- mkFlexVar - let tipe = VarN var - con <- constrain rtv expr (FromContext region (RecordUpdateValue field) tipe) - return (var, tipe, con) - - - --- CONSTRAIN TUPLE - - -constrainTuple :: RTV -> A.Region -> Can.Expr -> Can.Expr -> Maybe Can.Expr -> Expected Type -> IO Constraint -constrainTuple rtv region a b maybeC expected = - do aVar <- mkFlexVar - bVar <- mkFlexVar - let aType = VarN aVar - let bType = VarN bVar - - aCon <- constrain rtv a (NoExpectation aType) - bCon <- constrain rtv b (NoExpectation bType) - - case maybeC of - Nothing -> - do let tupleType = TupleN aType bType Nothing - let tupleCon = CEqual region Tuple tupleType expected - return $ exists [ aVar, bVar ] $ CAnd [ aCon, bCon, tupleCon ] - - Just c -> - do cVar <- mkFlexVar - let cType = VarN cVar - - cCon <- constrain rtv c (NoExpectation cType) - - let tupleType = TupleN aType bType (Just cType) - let tupleCon = CEqual region Tuple tupleType expected - - return $ exists [ aVar, bVar, cVar ] $ CAnd [ aCon, bCon, cCon, tupleCon ] - - - --- CONSTRAIN SHADER - - -constrainShader :: A.Region -> Shader.Types -> Expected Type -> IO Constraint -constrainShader region (Shader.Types attributes uniforms varyings) expected = - do attrVar <- mkFlexVar - unifVar <- mkFlexVar - let attrType = VarN attrVar - let unifType = VarN unifVar - - let shaderType = - AppN ModuleName.webgl Name.shader - [ toShaderRecord attributes attrType - , toShaderRecord uniforms unifType - , toShaderRecord varyings EmptyRecordN - ] - - return $ exists [ attrVar, unifVar ] $ - CEqual region Shader shaderType expected - - -toShaderRecord :: Map.Map Name.Name Shader.Type -> Type -> Type -toShaderRecord types baseRecType = - if Map.null types then - baseRecType - else - RecordN (Map.map glToType types) baseRecType - - -glToType :: Shader.Type -> Type -glToType glType = - case glType of - Shader.V2 -> Type.vec2 - Shader.V3 -> Type.vec3 - Shader.V4 -> Type.vec4 - Shader.M4 -> Type.mat4 - Shader.Int -> Type.int - Shader.Float -> Type.float - Shader.Texture -> Type.texture - - - --- CONSTRAIN DESTRUCTURES - - -constrainDestruct :: RTV -> A.Region -> Can.Pattern -> Can.Expr -> Constraint -> IO Constraint -constrainDestruct rtv region pattern expr bodyCon = - do patternVar <- mkFlexVar - let patternType = VarN patternVar - - (Pattern.State headers pvars revCons) <- - Pattern.add pattern (PNoExpectation patternType) Pattern.emptyState - - exprCon <- - constrain rtv expr (FromContext region Destructure patternType) - - return $ CLet [] (patternVar:pvars) headers (CAnd (reverse (exprCon:revCons))) bodyCon - - - --- CONSTRAIN DEF - - -constrainDef :: RTV -> Can.Def -> Constraint -> IO Constraint -constrainDef rtv def bodyCon = - case def of - Can.Def (A.At region name) args expr -> - do (Args vars tipe resultType (Pattern.State headers pvars revCons)) <- - constrainArgs args - - exprCon <- - constrain rtv expr (NoExpectation resultType) - - return $ - CLet - { _rigidVars = [] - , _flexVars = vars - , _header = Map.singleton name (A.At region tipe) - , _headerCon = - CLet - { _rigidVars = [] - , _flexVars = pvars - , _header = headers - , _headerCon = CAnd (reverse revCons) - , _bodyCon = exprCon - } - , _bodyCon = bodyCon - } - - Can.TypedDef (A.At region name) freeVars typedArgs expr srcResultType -> - do let newNames = Map.difference freeVars rtv - newRigids <- Map.traverseWithKey (\n _ -> nameToRigid n) newNames - let newRtv = Map.union rtv (Map.map VarN newRigids) - - (TypedArgs tipe resultType (Pattern.State headers pvars revCons)) <- - constrainTypedArgs newRtv name typedArgs srcResultType - - let expected = FromAnnotation name (length typedArgs) TypedBody resultType - exprCon <- - constrain newRtv expr expected - - return $ - CLet - { _rigidVars = Map.elems newRigids - , _flexVars = [] - , _header = Map.singleton name (A.At region tipe) - , _headerCon = - CLet - { _rigidVars = [] - , _flexVars = pvars - , _header = headers - , _headerCon = CAnd (reverse revCons) - , _bodyCon = exprCon - } - , _bodyCon = bodyCon - } - - - --- CONSTRAIN RECURSIVE DEFS - - -data Info = - Info - { _vars :: [Variable] - , _cons :: [Constraint] - , _headers :: Map.Map Name.Name (A.Located Type) - } - - -{-# NOINLINE emptyInfo #-} -emptyInfo :: Info -emptyInfo = - Info [] [] Map.empty - - -constrainRecursiveDefs :: RTV -> [Can.Def] -> Constraint -> IO Constraint -constrainRecursiveDefs rtv defs bodyCon = - recDefsHelp rtv defs bodyCon emptyInfo emptyInfo - - -recDefsHelp :: RTV -> [Can.Def] -> Constraint -> Info -> Info -> IO Constraint -recDefsHelp rtv defs bodyCon rigidInfo flexInfo = - case defs of - [] -> - do let (Info rigidVars rigidCons rigidHeaders) = rigidInfo - let (Info flexVars flexCons flexHeaders ) = flexInfo - return $ - CLet rigidVars [] rigidHeaders CTrue $ - CLet [] flexVars flexHeaders (CLet [] [] flexHeaders CTrue (CAnd flexCons)) $ - CAnd [ CAnd rigidCons, bodyCon ] - - def : otherDefs -> - case def of - Can.Def (A.At region name) args expr -> - do let (Info flexVars flexCons flexHeaders) = flexInfo - - (Args newFlexVars tipe resultType (Pattern.State headers pvars revCons)) <- - argsHelp args (Pattern.State Map.empty flexVars []) - - exprCon <- - constrain rtv expr (NoExpectation resultType) - - let defCon = - CLet - { _rigidVars = [] - , _flexVars = pvars - , _header = headers - , _headerCon = CAnd (reverse revCons) - , _bodyCon = exprCon - } - - recDefsHelp rtv otherDefs bodyCon rigidInfo $ - Info - { _vars = newFlexVars - , _cons = defCon : flexCons - , _headers = Map.insert name (A.At region tipe) flexHeaders - } - - Can.TypedDef (A.At region name) freeVars typedArgs expr srcResultType -> - do let newNames = Map.difference freeVars rtv - newRigids <- Map.traverseWithKey (\n _ -> nameToRigid n) newNames - let newRtv = Map.union rtv (Map.map VarN newRigids) - - (TypedArgs tipe resultType (Pattern.State headers pvars revCons)) <- - constrainTypedArgs newRtv name typedArgs srcResultType - - exprCon <- - constrain newRtv expr $ - FromAnnotation name (length typedArgs) TypedBody resultType - - let defCon = - CLet - { _rigidVars = [] - , _flexVars = pvars - , _header = headers - , _headerCon = CAnd (reverse revCons) - , _bodyCon = exprCon - } - - let (Info rigidVars rigidCons rigidHeaders) = rigidInfo - recDefsHelp rtv otherDefs bodyCon - ( Info - { _vars = Map.foldr (:) rigidVars newRigids - , _cons = CLet (Map.elems newRigids) [] Map.empty defCon CTrue : rigidCons - , _headers = Map.insert name (A.At region tipe) rigidHeaders - } - ) - flexInfo - - - --- CONSTRAIN ARGS - - -data Args = - Args - { _a_vars :: [Variable] - , _a_type :: Type - , _a_result :: Type - , _a_state :: Pattern.State - } - - -constrainArgs :: [Can.Pattern] -> IO Args -constrainArgs args = - argsHelp args Pattern.emptyState - - -argsHelp :: [Can.Pattern] -> Pattern.State -> IO Args -argsHelp args state = - case args of - [] -> - do resultVar <- mkFlexVar - let resultType = VarN resultVar - return $ Args [resultVar] resultType resultType state - - pattern : otherArgs -> - do argVar <- mkFlexVar - let argType = VarN argVar - - (Args vars tipe result newState) <- - argsHelp otherArgs =<< - Pattern.add pattern (PNoExpectation argType) state - - return (Args (argVar:vars) (FunN argType tipe) result newState) - - - --- CONSTRAIN TYPED ARGS - - -data TypedArgs = - TypedArgs - { _t_type :: Type - , _t_result :: Type - , _t_state :: Pattern.State - } - - -constrainTypedArgs :: Map.Map Name.Name Type -> Name.Name -> [(Can.Pattern, Can.Type)] -> Can.Type -> IO TypedArgs -constrainTypedArgs rtv name args srcResultType = - typedArgsHelp rtv name Index.first args srcResultType Pattern.emptyState - - -typedArgsHelp :: Map.Map Name.Name Type -> Name.Name -> Index.ZeroBased -> [(Can.Pattern, Can.Type)] -> Can.Type -> Pattern.State -> IO TypedArgs -typedArgsHelp rtv name index args srcResultType state = - case args of - [] -> - do resultType <- Instantiate.fromSrcType rtv srcResultType - return $ TypedArgs resultType resultType state - - (pattern@(A.At region _), srcType) : otherArgs -> - do argType <- Instantiate.fromSrcType rtv srcType - let expected = PFromContext region (PTypedArg name index) argType - - (TypedArgs tipe resultType newState) <- - typedArgsHelp rtv name (Index.next index) otherArgs srcResultType =<< - Pattern.add pattern expected state - - return (TypedArgs (FunN argType tipe) resultType newState) diff --git a/compiler/src/Type/Constrain/Module.hs b/compiler/src/Type/Constrain/Module.hs deleted file mode 100644 index 0b7d39f826..0000000000 --- a/compiler/src/Type/Constrain/Module.hs +++ /dev/null @@ -1,183 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE OverloadedStrings #-} -module Type.Constrain.Module - ( constrain - ) - where - - -import qualified Data.Map.Strict as Map -import qualified Data.Name as Name - -import qualified AST.Canonical as Can -import qualified Elm.ModuleName as ModuleName -import qualified Reporting.Annotation as A -import qualified Reporting.Error.Type as E -import qualified Type.Constrain.Expression as Expr -import qualified Type.Instantiate as Instantiate -import Type.Type (Type(..), Constraint(..), (==>), mkFlexVar, nameToRigid, never) - - - --- CONSTRAIN - - -constrain :: Can.Module -> IO Constraint -constrain (Can.Module home _ _ decls _ _ _ effects) = - case effects of - Can.NoEffects -> - constrainDecls decls CSaveTheEnvironment - - Can.Ports ports -> - Map.foldrWithKey letPort (constrainDecls decls CSaveTheEnvironment) ports - - Can.Manager r0 r1 r2 manager -> - case manager of - Can.Cmd cmdName -> - letCmd home cmdName =<< - constrainDecls decls =<< constrainEffects home r0 r1 r2 manager - - Can.Sub subName -> - letSub home subName =<< - constrainDecls decls =<< constrainEffects home r0 r1 r2 manager - - Can.Fx cmdName subName -> - letCmd home cmdName =<< - letSub home subName =<< - constrainDecls decls =<< constrainEffects home r0 r1 r2 manager - - - --- CONSTRAIN DECLARATIONS - - -constrainDecls :: Can.Decls -> Constraint -> IO Constraint -constrainDecls decls finalConstraint = - case decls of - Can.Declare def otherDecls -> - Expr.constrainDef Map.empty def =<< constrainDecls otherDecls finalConstraint - - Can.DeclareRec def defs otherDecls -> - Expr.constrainRecursiveDefs Map.empty (def:defs) =<< constrainDecls otherDecls finalConstraint - - Can.SaveTheEnvironment -> - return finalConstraint - - - --- PORT HELPERS - - -letPort :: Name.Name -> Can.Port -> IO Constraint -> IO Constraint -letPort name port_ makeConstraint = - case port_ of - Can.Incoming freeVars _ srcType -> - do vars <- Map.traverseWithKey (\k _ -> nameToRigid k) freeVars - tipe <- Instantiate.fromSrcType (Map.map VarN vars) srcType - let header = Map.singleton name (A.At A.zero tipe) - CLet (Map.elems vars) [] header CTrue <$> makeConstraint - - Can.Outgoing freeVars _ srcType -> - do vars <- Map.traverseWithKey (\k _ -> nameToRigid k) freeVars - tipe <- Instantiate.fromSrcType (Map.map VarN vars) srcType - let header = Map.singleton name (A.At A.zero tipe) - CLet (Map.elems vars) [] header CTrue <$> makeConstraint - - - --- EFFECT MANAGER HELPERS - - -letCmd :: ModuleName.Canonical -> Name.Name -> Constraint -> IO Constraint -letCmd home tipe constraint = - do msgVar <- mkFlexVar - let msg = VarN msgVar - let cmdType = FunN (AppN home tipe [msg]) (AppN ModuleName.cmd Name.cmd [msg]) - let header = Map.singleton "command" (A.At A.zero cmdType) - return $ CLet [msgVar] [] header CTrue constraint - - -letSub :: ModuleName.Canonical -> Name.Name -> Constraint -> IO Constraint -letSub home tipe constraint = - do msgVar <- mkFlexVar - let msg = VarN msgVar - let subType = FunN (AppN home tipe [msg]) (AppN ModuleName.sub Name.sub [msg]) - let header = Map.singleton "subscription" (A.At A.zero subType) - return $ CLet [msgVar] [] header CTrue constraint - - -constrainEffects :: ModuleName.Canonical -> A.Region -> A.Region -> A.Region -> Can.Manager -> IO Constraint -constrainEffects home r0 r1 r2 manager = - do s0 <- mkFlexVar - s1 <- mkFlexVar - s2 <- mkFlexVar - m1 <- mkFlexVar - m2 <- mkFlexVar - sm1 <- mkFlexVar - sm2 <- mkFlexVar - - let state0 = VarN s0 - let state1 = VarN s1 - let state2 = VarN s2 - let msg1 = VarN m1 - let msg2 = VarN m2 - let self1 = VarN sm1 - let self2 = VarN sm2 - - let onSelfMsg = router msg2 self2 ==> self2 ==> state2 ==> task state2 - let onEffects = - case manager of - Can.Cmd cmd -> router msg1 self1 ==> effectList home cmd msg1 ==> state1 ==> task state1 - Can.Sub sub -> router msg1 self1 ==> effectList home sub msg1 ==> state1 ==> task state1 - Can.Fx cmd sub -> router msg1 self1 ==> effectList home cmd msg1 ==> effectList home sub msg1 ==> state1 ==> task state1 - - let effectCons = - CAnd - [ CLocal r0 "init" (E.NoExpectation (task state0)) - , CLocal r1 "onEffects" (E.NoExpectation onEffects) - , CLocal r2 "onSelfMsg" (E.NoExpectation onSelfMsg) - , CEqual r1 E.Effects state0 (E.NoExpectation state1) - , CEqual r2 E.Effects state0 (E.NoExpectation state2) - , CEqual r2 E.Effects self1 (E.NoExpectation self2) - ] - - CLet [] [s0,s1,s2,m1,m2,sm1,sm2] Map.empty effectCons <$> - case manager of - Can.Cmd cmd -> - checkMap "cmdMap" home cmd CSaveTheEnvironment - - Can.Sub sub -> - checkMap "subMap" home sub CSaveTheEnvironment - - Can.Fx cmd sub -> - checkMap "cmdMap" home cmd =<< - checkMap "subMap" home sub CSaveTheEnvironment - - -effectList :: ModuleName.Canonical -> Name.Name -> Type -> Type -effectList home name msg = - AppN ModuleName.list Name.list [AppN home name [msg]] - - -task :: Type -> Type -task answer = - AppN ModuleName.platform Name.task [ never, answer ] - - -router :: Type -> Type -> Type -router msg self = - AppN ModuleName.platform Name.router [ msg, self ] - - -checkMap :: Name.Name -> ModuleName.Canonical -> Name.Name -> Constraint -> IO Constraint -checkMap name home tipe constraint = - do a <- mkFlexVar - b <- mkFlexVar - let mapType = toMapType home tipe (VarN a) (VarN b) - let mapCon = CLocal A.zero name (E.NoExpectation mapType) - return $ CLet [a,b] [] Map.empty mapCon constraint - - -toMapType :: ModuleName.Canonical -> Name.Name -> Type -> Type -> Type -toMapType home tipe a b = - (a ==> b) ==> AppN home tipe [a] ==> AppN home tipe [b] diff --git a/compiler/src/Type/Constrain/Pattern.hs b/compiler/src/Type/Constrain/Pattern.hs deleted file mode 100644 index 458b4c36a8..0000000000 --- a/compiler/src/Type/Constrain/Pattern.hs +++ /dev/null @@ -1,237 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -module Type.Constrain.Pattern - ( State(..) - , emptyState - , add - ) - where - - -import Control.Arrow (second) -import Control.Monad (foldM) -import qualified Data.Map.Strict as Map -import qualified Data.Name as Name - -import qualified AST.Canonical as Can -import qualified Data.Index as Index -import qualified Elm.ModuleName as ModuleName -import qualified Reporting.Annotation as A -import qualified Reporting.Error.Type as E -import qualified Type.Instantiate as Instantiate -import Type.Type as T - - - --- ACTUALLY ADD CONSTRAINTS - - --- The constraints are stored in reverse order so that adding a new --- constraint is O(1) and we can reverse it at some later time. --- -data State = - State - { _headers :: Header - , _vars :: [Variable] - , _revCons :: [Constraint] - } - - -type Header = Map.Map Name.Name (A.Located Type) - - -add :: Can.Pattern -> E.PExpected Type -> State -> IO State -add (A.At region pattern) expectation state = - case pattern of - Can.PAnything -> - return state - - Can.PVar name -> - return $ addToHeaders region name expectation state - - Can.PAlias realPattern name -> - add realPattern expectation $ - addToHeaders region name expectation state - - Can.PUnit -> - do let (State headers vars revCons) = state - let unitCon = CPattern region E.PUnit UnitN expectation - return $ State headers vars (unitCon:revCons) - - Can.PTuple a b maybeC -> - addTuple region a b maybeC expectation state - - Can.PCtor home typeName (Can.Union typeVars _ _ _) ctorName _ args -> - addCtor region home typeName typeVars ctorName args expectation state - - Can.PList patterns -> - do entryVar <- mkFlexVar - let entryType = VarN entryVar - let listType = AppN ModuleName.list Name.list [entryType] - - (State headers vars revCons) <- - foldM (addEntry region entryType) state (Index.indexedMap (,) patterns) - - let listCon = CPattern region E.PList listType expectation - return $ State headers (entryVar:vars) (listCon:revCons) - - Can.PCons headPattern tailPattern -> - do entryVar <- mkFlexVar - let entryType = VarN entryVar - let listType = AppN ModuleName.list Name.list [entryType] - - let headExpectation = E.PNoExpectation entryType - let tailExpectation = E.PFromContext region E.PTail listType - - (State headers vars revCons) <- - add headPattern headExpectation =<< - add tailPattern tailExpectation state - - let listCon = CPattern region E.PList listType expectation - return $ State headers (entryVar:vars) (listCon : revCons) - - Can.PRecord fields -> - do extVar <- mkFlexVar - let extType = VarN extVar - - fieldVars <- traverse (\field -> (,) field <$> mkFlexVar) fields - let fieldTypes = Map.fromList (map (fmap VarN) fieldVars) - let recordType = RecordN fieldTypes extType - - let (State headers vars revCons) = state - let recordCon = CPattern region E.PRecord recordType expectation - return $ - State - { _headers = Map.union headers (Map.map (A.At region) fieldTypes) - , _vars = map snd fieldVars ++ extVar : vars - , _revCons = recordCon : revCons - } - - Can.PInt _ -> - do let (State headers vars revCons) = state - let intCon = CPattern region E.PInt T.int expectation - return $ State headers vars (intCon:revCons) - - Can.PStr _ -> - do let (State headers vars revCons) = state - let strCon = CPattern region E.PStr T.string expectation - return $ State headers vars (strCon:revCons) - - Can.PChr _ -> - do let (State headers vars revCons) = state - let chrCon = CPattern region E.PChr T.char expectation - return $ State headers vars (chrCon:revCons) - - Can.PBool _ _ -> - do let (State headers vars revCons) = state - let boolCon = CPattern region E.PBool T.bool expectation - return $ State headers vars (boolCon:revCons) - - - --- STATE HELPERS - - -{-# NOINLINE emptyState #-} -emptyState :: State -emptyState = - State Map.empty [] [] - - -addToHeaders :: A.Region -> Name.Name -> E.PExpected Type -> State -> State -addToHeaders region name expectation (State headers vars revCons) = - let - tipe = getType expectation - newHeaders = Map.insert name (A.At region tipe) headers - in - State newHeaders vars revCons - - -getType :: E.PExpected Type -> Type -getType expectation = - case expectation of - E.PNoExpectation tipe -> tipe - E.PFromContext _ _ tipe -> tipe - - - --- CONSTRAIN LIST - - -addEntry :: A.Region -> Type -> State -> (Index.ZeroBased, Can.Pattern) -> IO State -addEntry listRegion tipe state (index, pattern) = - let - expectation = - E.PFromContext listRegion (E.PListEntry index) tipe - in - add pattern expectation state - - - --- CONSTRAIN TUPLE - - -addTuple :: A.Region -> Can.Pattern -> Can.Pattern -> Maybe Can.Pattern -> E.PExpected Type -> State -> IO State -addTuple region a b maybeC expectation state = - do aVar <- mkFlexVar - bVar <- mkFlexVar - let aType = VarN aVar - let bType = VarN bVar - - case maybeC of - Nothing -> - do (State headers vars revCons) <- - simpleAdd b bType =<< - simpleAdd a aType state - - let tupleCon = CPattern region E.PTuple (TupleN aType bType Nothing) expectation - - return $ State headers (aVar:bVar:vars) (tupleCon:revCons) - - Just c -> - do cVar <- mkFlexVar - let cType = VarN cVar - - (State headers vars revCons) <- - simpleAdd c cType =<< - simpleAdd b bType =<< - simpleAdd a aType state - - let tupleCon = CPattern region E.PTuple (TupleN aType bType (Just cType)) expectation - - return $ State headers (aVar:bVar:cVar:vars) (tupleCon:revCons) - - -simpleAdd :: Can.Pattern -> Type -> State -> IO State -simpleAdd pattern patternType state = - add pattern (E.PNoExpectation patternType) state - - - --- CONSTRAIN CONSTRUCTORS - - -addCtor :: A.Region -> ModuleName.Canonical -> Name.Name -> [Name.Name] -> Name.Name -> [Can.PatternCtorArg] -> E.PExpected Type -> State -> IO State -addCtor region home typeName typeVarNames ctorName args expectation state = - do varPairs <- traverse (\var -> (,) var <$> nameToFlex var) typeVarNames - let typePairs = map (second VarN) varPairs - let freeVarDict = Map.fromList typePairs - - (State headers vars revCons) <- - foldM (addCtorArg region ctorName freeVarDict) state args - - let ctorType = AppN home typeName (map snd typePairs) - let ctorCon = CPattern region (E.PCtor ctorName) ctorType expectation - - return $ - State - { _headers = headers - , _vars = map snd varPairs ++ vars - , _revCons = ctorCon : revCons - } - - -addCtorArg :: A.Region -> Name.Name -> Map.Map Name.Name Type -> State -> Can.PatternCtorArg -> IO State -addCtorArg region ctorName freeVarDict state (Can.PatternCtorArg index srcType pattern) = - do tipe <- Instantiate.fromSrcType freeVarDict srcType - let expectation = E.PFromContext region (E.PCtorArg ctorName index) tipe - add pattern expectation state diff --git a/compiler/src/Type/Error.hs b/compiler/src/Type/Error.hs deleted file mode 100644 index f1342993b0..0000000000 --- a/compiler/src/Type/Error.hs +++ /dev/null @@ -1,589 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE OverloadedStrings #-} -module Type.Error - ( Type(..) - , Super(..) - , Extension(..) - , iteratedDealias - , toDoc - , Problem(..) - , Direction(..) - , toComparison - , isInt - , isFloat - , isString - , isChar - , isList - ) - where - - -import qualified Data.Map as Map -import qualified Data.Maybe as Maybe -import Data.Monoid ((<>)) -import qualified Data.Name as Name - -import qualified Data.Bag as Bag -import qualified Elm.ModuleName as ModuleName -import qualified Reporting.Doc as D -import qualified Reporting.Render.Type as RT -import qualified Reporting.Render.Type.Localizer as L - - - --- ERROR TYPES - - -data Type - = Lambda Type Type [Type] - | Infinite - | Error - | FlexVar Name.Name - | FlexSuper Super Name.Name - | RigidVar Name.Name - | RigidSuper Super Name.Name - | Type ModuleName.Canonical Name.Name [Type] - | Record (Map.Map Name.Name Type) Extension - | Unit - | Tuple Type Type (Maybe Type) - | Alias ModuleName.Canonical Name.Name [(Name.Name, Type)] Type - - -data Super - = Number - | Comparable - | Appendable - | CompAppend - deriving (Eq) - - -data Extension - = Closed - | FlexOpen Name.Name - | RigidOpen Name.Name - - -iteratedDealias :: Type -> Type -iteratedDealias tipe = - case tipe of - Alias _ _ _ real -> - iteratedDealias real - - _ -> - tipe - - - --- TO DOC - - -toDoc :: L.Localizer -> RT.Context -> Type -> D.Doc -toDoc localizer ctx tipe = - case tipe of - Lambda a b cs -> - RT.lambda ctx - (toDoc localizer RT.Func a) - (toDoc localizer RT.Func b) - (map (toDoc localizer RT.Func) cs) - - Infinite -> - "∞" - - Error -> - "?" - - FlexVar name -> - D.fromName name - - FlexSuper _ name -> - D.fromName name - - RigidVar name -> - D.fromName name - - RigidSuper _ name -> - D.fromName name - - Type home name args -> - RT.apply ctx - (L.toDoc localizer home name) - (map (toDoc localizer RT.App) args) - - Record fields ext -> - RT.record (fieldsToDocs localizer fields) (extToDoc ext) - - Unit -> - "()" - - Tuple a b maybeC -> - RT.tuple - (toDoc localizer RT.None a) - (toDoc localizer RT.None b) - (map (toDoc localizer RT.None) (Maybe.maybeToList maybeC)) - - Alias home name args _ -> - aliasToDoc localizer ctx home name args - - -aliasToDoc :: L.Localizer -> RT.Context -> ModuleName.Canonical -> Name.Name -> [(Name.Name, Type)] -> D.Doc -aliasToDoc localizer ctx home name args = - RT.apply ctx - (L.toDoc localizer home name) - (map (toDoc localizer RT.App . snd) args) - - -fieldsToDocs :: L.Localizer -> Map.Map Name.Name Type -> [(D.Doc, D.Doc)] -fieldsToDocs localizer fields = - Map.foldrWithKey (addField localizer) [] fields - - -addField :: L.Localizer -> Name.Name -> Type -> [(D.Doc, D.Doc)] -> [(D.Doc, D.Doc)] -addField localizer fieldName fieldType docs = - let - f = D.fromName fieldName - t = toDoc localizer RT.None fieldType - in - (f,t) : docs - - -extToDoc :: Extension -> Maybe D.Doc -extToDoc ext = - case ext of - Closed -> Nothing - FlexOpen x -> Just (D.fromName x) - RigidOpen x -> Just (D.fromName x) - - - --- DIFF - - -data Diff a = - Diff a a Status - - -data Status - = Similar - | Different (Bag.Bag Problem) - - -data Problem - = IntFloat - | StringFromInt - | StringFromFloat - | StringToInt - | StringToFloat - | AnythingToBool - | AnythingFromMaybe - | ArityMismatch Int Int - | BadFlexSuper Direction Super Name.Name Type - | BadRigidVar Name.Name Type - | BadRigidSuper Super Name.Name Type - | FieldTypo Name.Name [Name.Name] - | FieldsMissing [Name.Name] - - -data Direction = Have | Need - - -instance Functor Diff where - fmap func (Diff a b status) = - Diff (func a) (func b) status - - -instance Applicative Diff where - pure a = - Diff a a Similar - - (<*>) (Diff aFunc bFunc status1) (Diff aArg bArg status2) = - Diff (aFunc aArg) (bFunc bArg) (merge status1 status2) - - -merge :: Status -> Status -> Status -merge status1 status2 = - case status1 of - Similar -> - status2 - - Different problems1 -> - case status2 of - Similar -> - status1 - - Different problems2 -> - Different (Bag.append problems1 problems2) - - - --- COMPARISON - - -toComparison :: L.Localizer -> Type -> Type -> (D.Doc, D.Doc, [Problem]) -toComparison localizer tipe1 tipe2 = - case toDiff localizer RT.None tipe1 tipe2 of - Diff doc1 doc2 Similar -> - (doc1, doc2, []) - - Diff doc1 doc2 (Different problems) -> - (doc1, doc2, Bag.toList problems) - - -toDiff :: L.Localizer -> RT.Context -> Type -> Type -> Diff D.Doc -toDiff localizer ctx tipe1 tipe2 = - case (tipe1, tipe2) of - (Unit , Unit ) -> same localizer ctx tipe1 - (Error , Error ) -> same localizer ctx tipe1 - (Infinite, Infinite) -> same localizer ctx tipe1 - - (FlexVar x, FlexVar y) | x == y -> same localizer ctx tipe1 - (FlexSuper _ x, FlexSuper _ y) | x == y -> same localizer ctx tipe1 - (RigidVar x, RigidVar y) | x == y -> same localizer ctx tipe1 - (RigidSuper _ x, RigidSuper _ y) | x == y -> same localizer ctx tipe1 - - (FlexVar _, _ ) -> similar localizer ctx tipe1 tipe2 - (_ , FlexVar _) -> similar localizer ctx tipe1 tipe2 - - (FlexSuper s _, t ) | isSuper s t -> similar localizer ctx tipe1 tipe2 - (t , FlexSuper s _) | isSuper s t -> similar localizer ctx tipe1 tipe2 - - (Lambda a b cs, Lambda x y zs) -> - if length cs == length zs then - RT.lambda ctx - <$> toDiff localizer RT.Func a x - <*> toDiff localizer RT.Func b y - <*> sequenceA (zipWith (toDiff localizer RT.Func) cs zs) - else - let f = toDoc localizer RT.Func in - different - (D.dullyellow (RT.lambda ctx (f a) (f b) (map f cs))) - (D.dullyellow (RT.lambda ctx (f x) (f y) (map f zs))) - (Bag.one (ArityMismatch (2 + length cs) (2 + length zs))) - - (Tuple a b Nothing, Tuple x y Nothing) -> - RT.tuple - <$> toDiff localizer RT.None a x - <*> toDiff localizer RT.None b y - <*> pure [] - - (Tuple a b (Just c), Tuple x y (Just z)) -> - RT.tuple - <$> toDiff localizer RT.None a x - <*> toDiff localizer RT.None b y - <*> ((:[]) <$> toDiff localizer RT.None c z) - - (Record fields1 ext1, Record fields2 ext2) -> - diffRecord localizer fields1 ext1 fields2 ext2 - - (Type home1 name1 args1, Type home2 name2 args2) | home1 == home2 && name1 == name2 -> - RT.apply ctx (L.toDoc localizer home1 name1) - <$> sequenceA (zipWith (toDiff localizer RT.App) args1 args2) - - (Alias home1 name1 args1 _, Alias home2 name2 args2 _) | home1 == home2 && name1 == name2 -> - RT.apply ctx (L.toDoc localizer home1 name1) - <$> sequenceA (zipWith (toDiff localizer RT.App) (map snd args1) (map snd args2)) - - -- start trying to find specific problems - - (Type home1 name1 args1, Type home2 name2 args2) | L.toChars localizer home1 name1 == L.toChars localizer home2 name2 -> - different - (nameClashToDoc ctx localizer home1 name1 args1) - (nameClashToDoc ctx localizer home2 name2 args2) - Bag.empty - - (Type home name [t1], t2) | isMaybe home name && isSimilar (toDiff localizer ctx t1 t2) -> - different - (RT.apply ctx (D.dullyellow (L.toDoc localizer home name)) [toDoc localizer RT.App t1]) - (toDoc localizer ctx t2) - (Bag.one AnythingFromMaybe) - - (t1, Type home name [t2]) | isList home name && isSimilar (toDiff localizer ctx t1 t2) -> - different - (toDoc localizer ctx t1) - (RT.apply ctx (D.dullyellow (L.toDoc localizer home name)) [toDoc localizer RT.App t2]) - Bag.empty - - (Alias home1 name1 args1 t1, t2) -> - case diffAliasedRecord localizer t1 t2 of - Just (Diff _ doc2 status) -> - Diff (D.dullyellow (aliasToDoc localizer ctx home1 name1 args1)) doc2 status - - Nothing -> - case t2 of - Type home2 name2 args2 | L.toChars localizer home1 name1 == L.toChars localizer home2 name2 -> - different - (nameClashToDoc ctx localizer home1 name1 (map snd args1)) - (nameClashToDoc ctx localizer home2 name2 args2) - Bag.empty - - _ -> - different - (D.dullyellow (toDoc localizer ctx tipe1)) - (D.dullyellow (toDoc localizer ctx tipe2)) - Bag.empty - - (t1, Alias home2 name2 args2 t2) -> - case diffAliasedRecord localizer t1 t2 of - Just (Diff doc1 _ status) -> - Diff doc1 (D.dullyellow (aliasToDoc localizer ctx home2 name2 args2)) status - - Nothing -> - case t1 of - Type home1 name1 args1 | L.toChars localizer home1 name1 == L.toChars localizer home2 name2 -> - different - (nameClashToDoc ctx localizer home1 name1 args1) - (nameClashToDoc ctx localizer home2 name2 (map snd args2)) - Bag.empty - - _ -> - different - (D.dullyellow (toDoc localizer ctx tipe1)) - (D.dullyellow (toDoc localizer ctx tipe2)) - Bag.empty - - pair -> - let - doc1 = D.dullyellow (toDoc localizer ctx tipe1) - doc2 = D.dullyellow (toDoc localizer ctx tipe2) - in - different doc1 doc2 $ - case pair of - (RigidVar x, other) -> Bag.one $ BadRigidVar x other - (FlexSuper s x, other) -> Bag.one $ BadFlexSuper Have s x other - (RigidSuper s x, other) -> Bag.one $ BadRigidSuper s x other - (other, RigidVar x) -> Bag.one $ BadRigidVar x other - (other, FlexSuper s x) -> Bag.one $ BadFlexSuper Need s x other - (other, RigidSuper s x) -> Bag.one $ BadRigidSuper s x other - - (Type home1 name1 [], Type home2 name2 []) - | isInt home1 name1 && isFloat home2 name2 -> Bag.one IntFloat - | isFloat home1 name1 && isInt home2 name2 -> Bag.one IntFloat - | isInt home1 name1 && isString home2 name2 -> Bag.one StringFromInt - | isFloat home1 name1 && isString home2 name2 -> Bag.one StringFromFloat - | isString home1 name1 && isInt home2 name2 -> Bag.one StringToInt - | isString home1 name1 && isFloat home2 name2 -> Bag.one StringToFloat - | isBool home2 name2 -> Bag.one AnythingToBool - - (_, _) -> - Bag.empty - - - --- DIFF HELPERS - - -same :: L.Localizer -> RT.Context -> Type -> Diff D.Doc -same localizer ctx tipe = - let - doc = toDoc localizer ctx tipe - in - Diff doc doc Similar - - -similar :: L.Localizer -> RT.Context -> Type -> Type -> Diff D.Doc -similar localizer ctx t1 t2 = - Diff (toDoc localizer ctx t1) (toDoc localizer ctx t2) Similar - - -different :: a -> a -> Bag.Bag Problem -> Diff a -different a b problems = - Diff a b (Different problems) - - -isSimilar :: Diff a -> Bool -isSimilar (Diff _ _ status) = - case status of - Similar -> True - Different _ -> False - - - --- IS TYPE? - - -isBool :: ModuleName.Canonical -> Name.Name -> Bool -isBool home name = - home == ModuleName.basics && name == Name.bool - - -isInt :: ModuleName.Canonical -> Name.Name -> Bool -isInt home name = - home == ModuleName.basics && name == Name.int - - -isFloat :: ModuleName.Canonical -> Name.Name -> Bool -isFloat home name = - home == ModuleName.basics && name == Name.float - - -isString :: ModuleName.Canonical -> Name.Name -> Bool -isString home name = - home == ModuleName.string && name == Name.string - - -isChar :: ModuleName.Canonical -> Name.Name -> Bool -isChar home name = - home == ModuleName.char && name == Name.char - - -isMaybe :: ModuleName.Canonical -> Name.Name -> Bool -isMaybe home name = - home == ModuleName.maybe && name == Name.maybe - - -isList :: ModuleName.Canonical -> Name.Name -> Bool -isList home name = - home == ModuleName.list && name == Name.list - - - --- IS SUPER? - - -isSuper :: Super -> Type -> Bool -isSuper super tipe = - case iteratedDealias tipe of - Type h n args -> - case super of - Number -> isInt h n || isFloat h n - Comparable -> isInt h n || isFloat h n || isString h n || isChar h n || isList h n && isSuper super (head args) - Appendable -> isString h n || isList h n - CompAppend -> isString h n || isList h n && isSuper Comparable (head args) - - Tuple a b maybeC -> - case super of - Number -> False - Comparable -> isSuper super a && isSuper super b && maybe True (isSuper super) maybeC - Appendable -> False - CompAppend -> False - - _ -> - False - - - --- NAME CLASH - - -nameClashToDoc :: RT.Context -> L.Localizer -> ModuleName.Canonical -> Name.Name -> [Type] -> D.Doc -nameClashToDoc ctx localizer (ModuleName.Canonical _ home) name args = - RT.apply ctx - (D.yellow (D.fromName home) <> D.dullyellow ("." <> D.fromName name)) - (map (toDoc localizer RT.App) args) - - - --- DIFF ALIASED RECORD - - -diffAliasedRecord :: L.Localizer -> Type -> Type -> Maybe (Diff D.Doc) -diffAliasedRecord localizer t1 t2 = - case (iteratedDealias t1, iteratedDealias t2) of - (Record fields1 ext1, Record fields2 ext2) -> - Just (diffRecord localizer fields1 ext1 fields2 ext2) - - _ -> - Nothing - - - --- RECORD DIFFS - - -diffRecord :: L.Localizer -> Map.Map Name.Name Type -> Extension -> Map.Map Name.Name Type -> Extension -> Diff D.Doc -diffRecord localizer fields1 ext1 fields2 ext2 = - let - toUnknownDocs field tipe = - ( D.dullyellow (D.fromName field), toDoc localizer RT.None tipe ) - - toOverlapDocs field t1 t2 = - (,) (D.fromName field) <$> toDiff localizer RT.None t1 t2 - - left = Map.mapWithKey toUnknownDocs (Map.difference fields1 fields2) - both = Map.intersectionWithKey toOverlapDocs fields1 fields2 - right = Map.mapWithKey toUnknownDocs (Map.difference fields2 fields1) - - fieldsDiff = - Map.elems <$> - if Map.null left && Map.null right then - sequenceA both - else - Map.union - <$> sequenceA both - <*> Diff left right (Different Bag.empty) - - (Diff doc1 doc2 status) = - RT.record - <$> fieldsDiff - <*> extToDiff ext1 ext2 - in - Diff doc1 doc2 $ merge status $ - case (hasFixedFields ext1, hasFixedFields ext2) of - (True, True) -> - case Map.lookupMin left of - Just (f,_) -> Different $ Bag.one $ FieldTypo f (Map.keys fields2) - Nothing -> - if Map.null right - then Similar - else Different $ Bag.one $ FieldsMissing (Map.keys right) - - (False, True) -> - case Map.lookupMin left of - Just (f,_) -> Different $ Bag.one $ FieldTypo f (Map.keys fields2) - Nothing -> Similar - - (True, False) -> - case Map.lookupMin right of - Just (f,_) -> Different $ Bag.one $ FieldTypo f (Map.keys fields1) - Nothing -> Similar - - (False, False) -> - Similar - - -hasFixedFields :: Extension -> Bool -hasFixedFields ext = - case ext of - Closed -> True - FlexOpen _ -> False - RigidOpen _ -> True - - - --- DIFF RECORD EXTENSION - - -extToDiff :: Extension -> Extension -> Diff (Maybe D.Doc) -extToDiff ext1 ext2 = - let - status = extToStatus ext1 ext2 - extDoc1 = extToDoc ext1 - extDoc2 = extToDoc ext2 - in - case status of - Similar -> - Diff extDoc1 extDoc2 status - - Different _ -> - Diff (D.dullyellow <$> extDoc1) (D.dullyellow <$> extDoc2) status - - -extToStatus :: Extension -> Extension -> Status -extToStatus ext1 ext2 = - case ext1 of - Closed -> - case ext2 of - Closed -> Similar - FlexOpen _ -> Similar - RigidOpen _ -> Different Bag.empty - - FlexOpen _ -> - Similar - - RigidOpen x -> - case ext2 of - Closed -> Different Bag.empty - FlexOpen _ -> Similar - RigidOpen y -> - if x == y - then Similar - else Different $ Bag.one $ BadRigidVar x (RigidVar y) diff --git a/compiler/src/Type/Instantiate.hs b/compiler/src/Type/Instantiate.hs deleted file mode 100644 index 8f6530003f..0000000000 --- a/compiler/src/Type/Instantiate.hs +++ /dev/null @@ -1,77 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE OverloadedStrings #-} -module Type.Instantiate - ( FreeVars - , fromSrcType - ) - where - - -import qualified Data.Map.Strict as Map -import Data.Map.Strict ((!)) -import qualified Data.Name as Name - -import qualified AST.Canonical as Can -import Type.Type - - - --- FREE VARS - - -type FreeVars = - Map.Map Name.Name Type - - - --- FROM SOURCE TYPE - - -fromSrcType :: Map.Map Name.Name Type -> Can.Type -> IO Type -fromSrcType freeVars sourceType = - case sourceType of - Can.TLambda arg result -> - FunN - <$> fromSrcType freeVars arg - <*> fromSrcType freeVars result - - Can.TVar name -> - return (freeVars ! name) - - Can.TType home name args -> - AppN home name <$> traverse (fromSrcType freeVars) args - - Can.TAlias home name args aliasedType -> - do targs <- traverse (traverse (fromSrcType freeVars)) args - AliasN home name targs <$> - case aliasedType of - Can.Filled realType -> - fromSrcType freeVars realType - - Can.Holey realType -> - fromSrcType (Map.fromList targs) realType - - Can.TTuple a b maybeC -> - TupleN - <$> fromSrcType freeVars a - <*> fromSrcType freeVars b - <*> traverse (fromSrcType freeVars) maybeC - - Can.TUnit -> - return UnitN - - Can.TRecord fields maybeExt -> - RecordN - <$> traverse (fromSrcFieldType freeVars) fields - <*> - case maybeExt of - Nothing -> - return EmptyRecordN - - Just ext -> - return (freeVars ! ext) - - -fromSrcFieldType :: Map.Map Name.Name Type -> Can.FieldType -> IO Type -fromSrcFieldType freeVars (Can.FieldType _ tipe) = - fromSrcType freeVars tipe diff --git a/compiler/src/Type/Occurs.hs b/compiler/src/Type/Occurs.hs deleted file mode 100644 index 63092f4b4c..0000000000 --- a/compiler/src/Type/Occurs.hs +++ /dev/null @@ -1,80 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE OverloadedStrings #-} -module Type.Occurs - ( occurs - ) - where - - -import Data.Foldable (foldrM) -import qualified Data.Map.Strict as Map - -import Type.Type as Type -import qualified Type.UnionFind as UF - - - --- OCCURS - - -occurs :: Type.Variable -> IO Bool -occurs var = - occursHelp [] var False - - -occursHelp :: [Type.Variable] -> Type.Variable -> Bool -> IO Bool -occursHelp seen var foundCycle = - if elem var seen then - return True - - else - do (Descriptor content _ _ _) <- UF.get var - case content of - FlexVar _ -> - return foundCycle - - FlexSuper _ _ -> - return foundCycle - - RigidVar _ -> - return foundCycle - - RigidSuper _ _ -> - return foundCycle - - Structure term -> - let newSeen = var : seen in - case term of - App1 _ _ args -> - foldrM (occursHelp newSeen) foundCycle args - - Fun1 a b -> - occursHelp newSeen a =<< - occursHelp newSeen b foundCycle - - EmptyRecord1 -> - return foundCycle - - Record1 fields ext -> - occursHelp newSeen ext =<< - foldrM (occursHelp newSeen) foundCycle (Map.elems fields) - - Unit1 -> - return foundCycle - - Tuple1 a b maybeC -> - case maybeC of - Nothing -> - occursHelp newSeen a =<< - occursHelp newSeen b foundCycle - - Just c -> - occursHelp newSeen a =<< - occursHelp newSeen b =<< - occursHelp newSeen c foundCycle - - Alias _ _ args _ -> - foldrM (occursHelp (var:seen)) foundCycle (map snd args) - - Error -> - return foundCycle diff --git a/compiler/src/Type/Solve.hs b/compiler/src/Type/Solve.hs deleted file mode 100644 index 252b62e4b8..0000000000 --- a/compiler/src/Type/Solve.hs +++ /dev/null @@ -1,727 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE OverloadedStrings #-} -module Type.Solve - ( run - ) - where - - -import Control.Monad -import qualified Data.Map.Strict as Map -import Data.Map.Strict ((!)) -import qualified Data.Name as Name -import qualified Data.NonEmptyList as NE -import qualified Data.Vector as Vector -import qualified Data.Vector.Mutable as MVector - -import qualified AST.Canonical as Can -import qualified Reporting.Annotation as A -import qualified Reporting.Error.Type as Error -import qualified Reporting.Render.Type as RT -import qualified Reporting.Render.Type.Localizer as L -import qualified Type.Occurs as Occurs -import Type.Type as Type -import qualified Type.Error as ET -import qualified Type.Unify as Unify -import qualified Type.UnionFind as UF - - - --- RUN SOLVER - - -run :: Constraint -> IO (Either (NE.List Error.Error) (Map.Map Name.Name Can.Annotation)) -run constraint = - do pools <- MVector.replicate 8 [] - - (State env _ errors) <- - solve Map.empty outermostRank pools emptyState constraint - - case errors of - [] -> - Right <$> traverse Type.toAnnotation env - - e:es -> - return $ Left (NE.List e es) - - - -{-# NOINLINE emptyState #-} -emptyState :: State -emptyState = - State Map.empty (nextMark noMark) [] - - - --- SOLVER - - -type Env = - Map.Map Name.Name Variable - - -type Pools = - MVector.IOVector [Variable] - - -data State = - State - { _env :: Env - , _mark :: Mark - , _errors :: [Error.Error] - } - - -solve :: Env -> Int -> Pools -> State -> Constraint -> IO State -solve env rank pools state constraint = - case constraint of - CTrue -> - return state - - CSaveTheEnvironment -> - return (state { _env = env }) - - CEqual region category tipe expectation -> - do actual <- typeToVariable rank pools tipe - expected <- expectedToVariable rank pools expectation - answer <- Unify.unify actual expected - case answer of - Unify.Ok vars -> - do introduce rank pools vars - return state - - Unify.Err vars actualType expectedType -> - do introduce rank pools vars - return $ addError state $ - Error.BadExpr region category actualType $ - Error.typeReplace expectation expectedType - - CLocal region name expectation -> - do actual <- makeCopy rank pools (env ! name) - expected <- expectedToVariable rank pools expectation - answer <- Unify.unify actual expected - case answer of - Unify.Ok vars -> - do introduce rank pools vars - return state - - Unify.Err vars actualType expectedType -> - do introduce rank pools vars - return $ addError state $ - Error.BadExpr region (Error.Local name) actualType $ - Error.typeReplace expectation expectedType - - CForeign region name (Can.Forall freeVars srcType) expectation -> - do actual <- srcTypeToVariable rank pools freeVars srcType - expected <- expectedToVariable rank pools expectation - answer <- Unify.unify actual expected - case answer of - Unify.Ok vars -> - do introduce rank pools vars - return state - - Unify.Err vars actualType expectedType -> - do introduce rank pools vars - return $ addError state $ - Error.BadExpr region (Error.Foreign name) actualType $ - Error.typeReplace expectation expectedType - - CPattern region category tipe expectation -> - do actual <- typeToVariable rank pools tipe - expected <- patternExpectationToVariable rank pools expectation - answer <- Unify.unify actual expected - case answer of - Unify.Ok vars -> - do introduce rank pools vars - return state - - Unify.Err vars actualType expectedType -> - do introduce rank pools vars - return $ addError state $ - Error.BadPattern region category actualType - (Error.ptypeReplace expectation expectedType) - - CAnd constraints -> - foldM (solve env rank pools) state constraints - - CLet [] flexs _ headerCon CTrue -> - do introduce rank pools flexs - solve env rank pools state headerCon - - CLet [] [] header headerCon subCon -> - do state1 <- solve env rank pools state headerCon - locals <- traverse (A.traverse (typeToVariable rank pools)) header - let newEnv = Map.union env (Map.map A.toValue locals) - state2 <- solve newEnv rank pools state1 subCon - foldM occurs state2 $ Map.toList locals - - CLet rigids flexs header headerCon subCon -> - do - -- work in the next pool to localize header - let nextRank = rank + 1 - let poolsLength = MVector.length pools - nextPools <- - if nextRank < poolsLength - then return pools - else MVector.grow pools poolsLength - - -- introduce variables - let vars = rigids ++ flexs - forM_ vars $ \var -> - UF.modify var $ \(Descriptor content _ mark copy) -> - Descriptor content nextRank mark copy - MVector.write nextPools nextRank vars - - -- run solver in next pool - locals <- traverse (A.traverse (typeToVariable nextRank nextPools)) header - (State savedEnv mark errors) <- - solve env nextRank nextPools state headerCon - - let youngMark = mark - let visitMark = nextMark youngMark - let finalMark = nextMark visitMark - - -- pop pool - generalize youngMark visitMark nextRank nextPools - MVector.write nextPools nextRank [] - - -- check that things went well - mapM_ isGeneric rigids - - let newEnv = Map.union env (Map.map A.toValue locals) - let tempState = State savedEnv finalMark errors - newState <- solve newEnv rank nextPools tempState subCon - - foldM occurs newState (Map.toList locals) - - --- Check that a variable has rank == noRank, meaning that it can be generalized. -isGeneric :: Variable -> IO () -isGeneric var = - do (Descriptor _ rank _ _) <- UF.get var - if rank == noRank - then return () - else - do tipe <- Type.toErrorType var - error $ - "You ran into a compiler bug. Here are some details for the developers:\n\n" - ++ " " ++ show (ET.toDoc L.empty RT.None tipe) ++ " [rank = " ++ show rank ++ "]\n\n" - ++ - "Please create an and then report it\n\ - \at \n\n" - - - --- EXPECTATIONS TO VARIABLE - - -expectedToVariable :: Int -> Pools -> Error.Expected Type -> IO Variable -expectedToVariable rank pools expectation = - typeToVariable rank pools $ - case expectation of - Error.NoExpectation tipe -> - tipe - - Error.FromContext _ _ tipe -> - tipe - - Error.FromAnnotation _ _ _ tipe -> - tipe - - -patternExpectationToVariable :: Int -> Pools -> Error.PExpected Type -> IO Variable -patternExpectationToVariable rank pools expectation = - typeToVariable rank pools $ - case expectation of - Error.PNoExpectation tipe -> - tipe - - Error.PFromContext _ _ tipe -> - tipe - - - --- ERROR HELPERS - - -addError :: State -> Error.Error -> State -addError (State savedEnv rank errors) err = - State savedEnv rank (err:errors) - - - --- OCCURS CHECK - - -occurs :: State -> (Name.Name, A.Located Variable) -> IO State -occurs state (name, A.At region variable) = - do hasOccurred <- Occurs.occurs variable - if hasOccurred - then - do errorType <- Type.toErrorType variable - (Descriptor _ rank mark copy) <- UF.get variable - UF.set variable (Descriptor Error rank mark copy) - return $ addError state (Error.InfiniteType region name errorType) - else - return state - - - --- GENERALIZE - - -{-| Every variable has rank less than or equal to the maxRank of the pool. -This sorts variables into the young and old pools accordingly. --} -generalize :: Mark -> Mark -> Int -> Pools -> IO () -generalize youngMark visitMark youngRank pools = - do youngVars <- MVector.read pools youngRank - rankTable <- poolToRankTable youngMark youngRank youngVars - - -- get the ranks right for each entry. - -- start at low ranks so that we only have to pass - -- over the information once. - Vector.imapM_ - (\rank table -> mapM_ (adjustRank youngMark visitMark rank) table) - rankTable - - -- For variables that have rank lowerer than youngRank, register them in - -- the appropriate old pool if they are not redundant. - Vector.forM_ (Vector.unsafeInit rankTable) $ \vars -> - forM_ vars $ \var -> - do isRedundant <- UF.redundant var - if isRedundant - then return () - else - do (Descriptor _ rank _ _) <- UF.get var - MVector.modify pools (var:) rank - - -- For variables with rank youngRank - -- If rank < youngRank: register in oldPool - -- otherwise generalize - forM_ (Vector.unsafeLast rankTable) $ \var -> - do isRedundant <- UF.redundant var - if isRedundant - then return () - else - do (Descriptor content rank mark copy) <- UF.get var - if rank < youngRank - then MVector.modify pools (var:) rank - else UF.set var $ Descriptor content noRank mark copy - - -poolToRankTable :: Mark -> Int -> [Variable] -> IO (Vector.Vector [Variable]) -poolToRankTable youngMark youngRank youngInhabitants = - do mutableTable <- MVector.replicate (youngRank + 1) [] - - -- Sort the youngPool variables into buckets by rank. - forM_ youngInhabitants $ \var -> - do (Descriptor content rank _ copy) <- UF.get var - UF.set var (Descriptor content rank youngMark copy) - MVector.modify mutableTable (var:) rank - - Vector.unsafeFreeze mutableTable - - - --- ADJUST RANK - --- --- Adjust variable ranks such that ranks never increase as you move deeper. --- This way the outermost rank is representative of the entire structure. --- -adjustRank :: Mark -> Mark -> Int -> Variable -> IO Int -adjustRank youngMark visitMark groupRank var = - do (Descriptor content rank mark copy) <- UF.get var - if mark == youngMark then - do -- Set the variable as marked first because it may be cyclic. - UF.set var $ Descriptor content rank visitMark copy - maxRank <- adjustRankContent youngMark visitMark groupRank content - UF.set var $ Descriptor content maxRank visitMark copy - return maxRank - - else if mark == visitMark then - return rank - - else - do let minRank = min groupRank rank - -- TODO how can minRank ever be groupRank? - UF.set var $ Descriptor content minRank visitMark copy - return minRank - - -adjustRankContent :: Mark -> Mark -> Int -> Content -> IO Int -adjustRankContent youngMark visitMark groupRank content = - let - go = adjustRank youngMark visitMark groupRank - in - case content of - FlexVar _ -> - return groupRank - - FlexSuper _ _ -> - return groupRank - - RigidVar _ -> - return groupRank - - RigidSuper _ _ -> - return groupRank - - Structure flatType -> - case flatType of - App1 _ _ args -> - foldM (\rank arg -> max rank <$> go arg) outermostRank args - - Fun1 arg result -> - max <$> go arg <*> go result - - EmptyRecord1 -> - -- THEORY: an empty record never needs to get generalized - return outermostRank - - Record1 fields extension -> - do extRank <- go extension - foldM (\rank field -> max rank <$> go field) extRank fields - - Unit1 -> - -- THEORY: a unit never needs to get generalized - return outermostRank - - Tuple1 a b maybeC -> - do ma <- go a - mb <- go b - case maybeC of - Nothing -> - return (max ma mb) - - Just c -> - max (max ma mb) <$> go c - - Alias _ _ args _ -> - -- THEORY: anything in the realVar would be outermostRank - foldM (\rank (_, argVar) -> max rank <$> go argVar) outermostRank args - - Error -> - return groupRank - - - --- REGISTER VARIABLES - - -introduce :: Int -> Pools -> [Variable] -> IO () -introduce rank pools variables = - do MVector.modify pools (variables++) rank - forM_ variables $ \var -> - UF.modify var $ \(Descriptor content _ mark copy) -> - Descriptor content rank mark copy - - - --- TYPE TO VARIABLE - - -typeToVariable :: Int -> Pools -> Type -> IO Variable -typeToVariable rank pools tipe = - typeToVar rank pools Map.empty tipe - - --- PERF working with @mgriffith we noticed that a 784 line entry in a `let` was --- causing a ~1.5 second slowdown. Moving it to the top-level to be a function --- saved all that time. The slowdown seems to manifest in `typeToVar` and in --- `register` in particular. Have not explored further yet. Top-level definitions --- are recommended in cases like this anyway, so there is at least a safety --- valve for now. --- -typeToVar :: Int -> Pools -> Map.Map Name.Name Variable -> Type -> IO Variable -typeToVar rank pools aliasDict tipe = - let go = typeToVar rank pools aliasDict in - case tipe of - VarN v -> - return v - - AppN home name args -> - do argVars <- traverse go args - register rank pools (Structure (App1 home name argVars)) - - FunN a b -> - do aVar <- go a - bVar <- go b - register rank pools (Structure (Fun1 aVar bVar)) - - AliasN home name args aliasType -> - do argVars <- traverse (traverse go) args - aliasVar <- typeToVar rank pools (Map.fromList argVars) aliasType - register rank pools (Alias home name argVars aliasVar) - - PlaceHolder name -> - return (aliasDict ! name) - - RecordN fields ext -> - do fieldVars <- traverse go fields - extVar <- go ext - register rank pools (Structure (Record1 fieldVars extVar)) - - EmptyRecordN -> - register rank pools emptyRecord1 - - UnitN -> - register rank pools unit1 - - TupleN a b c -> - do aVar <- go a - bVar <- go b - cVar <- traverse go c - register rank pools (Structure (Tuple1 aVar bVar cVar)) - - -register :: Int -> Pools -> Content -> IO Variable -register rank pools content = - do var <- UF.fresh (Descriptor content rank noMark Nothing) - MVector.modify pools (var:) rank - return var - - -{-# NOINLINE emptyRecord1 #-} -emptyRecord1 :: Content -emptyRecord1 = - Structure EmptyRecord1 - - -{-# NOINLINE unit1 #-} -unit1 :: Content -unit1 = - Structure Unit1 - - - --- SOURCE TYPE TO VARIABLE - - -srcTypeToVariable :: Int -> Pools -> Map.Map Name.Name () -> Can.Type -> IO Variable -srcTypeToVariable rank pools freeVars srcType = - let - nameToContent name - | Name.isNumberType name = FlexSuper Number (Just name) - | Name.isComparableType name = FlexSuper Comparable (Just name) - | Name.isAppendableType name = FlexSuper Appendable (Just name) - | Name.isCompappendType name = FlexSuper CompAppend (Just name) - | otherwise = FlexVar (Just name) - - makeVar name _ = - UF.fresh (Descriptor (nameToContent name) rank noMark Nothing) - in - do flexVars <- Map.traverseWithKey makeVar freeVars - MVector.modify pools (Map.elems flexVars ++) rank - srcTypeToVar rank pools flexVars srcType - - -srcTypeToVar :: Int -> Pools -> Map.Map Name.Name Variable -> Can.Type -> IO Variable -srcTypeToVar rank pools flexVars srcType = - let go = srcTypeToVar rank pools flexVars in - case srcType of - Can.TLambda argument result -> - do argVar <- go argument - resultVar <- go result - register rank pools (Structure (Fun1 argVar resultVar)) - - Can.TVar name -> - return (flexVars ! name) - - Can.TType home name args -> - do argVars <- traverse go args - register rank pools (Structure (App1 home name argVars)) - - Can.TRecord fields maybeExt -> - do fieldVars <- traverse (srcFieldTypeToVar rank pools flexVars) fields - extVar <- - case maybeExt of - Nothing -> register rank pools emptyRecord1 - Just ext -> return (flexVars ! ext) - register rank pools (Structure (Record1 fieldVars extVar)) - - Can.TUnit -> - register rank pools unit1 - - Can.TTuple a b c -> - do aVar <- go a - bVar <- go b - cVar <- traverse go c - register rank pools (Structure (Tuple1 aVar bVar cVar)) - - Can.TAlias home name args aliasType -> - do argVars <- traverse (traverse go) args - aliasVar <- - case aliasType of - Can.Holey tipe -> - srcTypeToVar rank pools (Map.fromList argVars) tipe - - Can.Filled tipe -> - go tipe - - register rank pools (Alias home name argVars aliasVar) - - -srcFieldTypeToVar :: Int -> Pools -> Map.Map Name.Name Variable -> Can.FieldType -> IO Variable -srcFieldTypeToVar rank pools flexVars (Can.FieldType _ srcTipe) = - srcTypeToVar rank pools flexVars srcTipe - - - --- COPY - - -makeCopy :: Int -> Pools -> Variable -> IO Variable -makeCopy rank pools var = - do copy <- makeCopyHelp rank pools var - restore var - return copy - - -makeCopyHelp :: Int -> Pools -> Variable -> IO Variable -makeCopyHelp maxRank pools variable = - do (Descriptor content rank _ maybeCopy) <- UF.get variable - - case maybeCopy of - Just copy -> - return copy - - Nothing -> - if rank /= noRank then - return variable - - else - do let makeDescriptor c = Descriptor c maxRank noMark Nothing - copy <- UF.fresh $ makeDescriptor content - MVector.modify pools (copy:) maxRank - - -- Link the original variable to the new variable. This lets us - -- avoid making multiple copies of the variable we are instantiating. - -- - -- Need to do this before recursively copying to avoid looping. - UF.set variable $ - Descriptor content rank noMark (Just copy) - - -- Now we recursively copy the content of the variable. - -- We have already marked the variable as copied, so we - -- will not repeat this work or crawl this variable again. - case content of - Structure term -> - do newTerm <- traverseFlatType (makeCopyHelp maxRank pools) term - UF.set copy $ makeDescriptor (Structure newTerm) - return copy - - FlexVar _ -> - return copy - - FlexSuper _ _ -> - return copy - - RigidVar name -> - do UF.set copy $ makeDescriptor $ FlexVar (Just name) - return copy - - RigidSuper super name -> - do UF.set copy $ makeDescriptor $ FlexSuper super (Just name) - return copy - - Alias home name args realType -> - do newArgs <- mapM (traverse (makeCopyHelp maxRank pools)) args - newRealType <- makeCopyHelp maxRank pools realType - UF.set copy $ makeDescriptor (Alias home name newArgs newRealType) - return copy - - Error -> - return copy - - - --- RESTORE - - -restore :: Variable -> IO () -restore variable = - do (Descriptor content _ _ maybeCopy) <- UF.get variable - case maybeCopy of - Nothing -> - return () - - Just _ -> - do UF.set variable $ Descriptor content noRank noMark Nothing - restoreContent content - - -restoreContent :: Content -> IO () -restoreContent content = - case content of - FlexVar _ -> - return () - - FlexSuper _ _ -> - return () - - RigidVar _ -> - return () - - RigidSuper _ _ -> - return () - - Structure term -> - case term of - App1 _ _ args -> - mapM_ restore args - - Fun1 arg result -> - do restore arg - restore result - - EmptyRecord1 -> - return () - - Record1 fields ext -> - do mapM_ restore fields - restore ext - - Unit1 -> - return () - - Tuple1 a b maybeC -> - do restore a - restore b - case maybeC of - Nothing -> return () - Just c -> restore c - - Alias _ _ args var -> - do mapM_ (traverse restore) args - restore var - - Error -> - return () - - - --- TRAVERSE FLAT TYPE - - -traverseFlatType :: (Variable -> IO Variable) -> FlatType -> IO FlatType -traverseFlatType f flatType = - case flatType of - App1 home name args -> - liftM (App1 home name) (traverse f args) - - Fun1 a b -> - liftM2 Fun1 (f a) (f b) - - EmptyRecord1 -> - pure EmptyRecord1 - - Record1 fields ext -> - liftM2 Record1 (traverse f fields) (f ext) - - Unit1 -> - pure Unit1 - - Tuple1 a b cs -> - liftM3 Tuple1 (f a) (f b) (traverse f cs) diff --git a/compiler/src/Type/Type.hs b/compiler/src/Type/Type.hs deleted file mode 100644 index 91043904c5..0000000000 --- a/compiler/src/Type/Type.hs +++ /dev/null @@ -1,726 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE OverloadedStrings #-} -module Type.Type - ( Constraint(..) - , exists - , Variable - , FlatType(..) - , Type(..) - , Descriptor(Descriptor) - , Content(..) - , SuperType(..) - , noRank - , outermostRank - , Mark - , noMark - , nextMark - , (==>) - , int, float, char, string, bool, never - , vec2, vec3, vec4, mat4, texture - , mkFlexVar - , mkFlexNumber - , unnamedFlexVar - , unnamedFlexSuper - , nameToFlex - , nameToRigid - , toAnnotation - , toErrorType - ) - where - - -import Control.Monad.State.Strict (StateT, liftIO) -import qualified Control.Monad.State.Strict as State -import Data.Foldable (foldrM) -import qualified Data.Map.Strict as Map -import qualified Data.Name as Name -import Data.Word (Word32) - -import qualified AST.Canonical as Can -import qualified AST.Utils.Type as Type -import qualified Elm.ModuleName as ModuleName -import qualified Reporting.Annotation as A -import qualified Reporting.Error.Type as E -import qualified Type.Error as ET -import qualified Type.UnionFind as UF - - - --- CONSTRAINTS - - -data Constraint - = CTrue - | CSaveTheEnvironment - | CEqual A.Region E.Category Type (E.Expected Type) - | CLocal A.Region Name.Name (E.Expected Type) - | CForeign A.Region Name.Name Can.Annotation (E.Expected Type) - | CPattern A.Region E.PCategory Type (E.PExpected Type) - | CAnd [Constraint] - | CLet - { _rigidVars :: [Variable] - , _flexVars :: [Variable] - , _header :: Map.Map Name.Name (A.Located Type) - , _headerCon :: Constraint - , _bodyCon :: Constraint - } - - -exists :: [Variable] -> Constraint -> Constraint -exists flexVars constraint = - CLet [] flexVars Map.empty constraint CTrue - - - --- TYPE PRIMITIVES - - -type Variable = - UF.Point Descriptor - - -data FlatType - = App1 ModuleName.Canonical Name.Name [Variable] - | Fun1 Variable Variable - | EmptyRecord1 - | Record1 (Map.Map Name.Name Variable) Variable - | Unit1 - | Tuple1 Variable Variable (Maybe Variable) - - -data Type - = PlaceHolder Name.Name - | AliasN ModuleName.Canonical Name.Name [(Name.Name, Type)] Type - | VarN Variable - | AppN ModuleName.Canonical Name.Name [Type] - | FunN Type Type - | EmptyRecordN - | RecordN (Map.Map Name.Name Type) Type - | UnitN - | TupleN Type Type (Maybe Type) - - - --- DESCRIPTORS - - -data Descriptor = - Descriptor - { _content :: Content - , _rank :: Int - , _mark :: Mark - , _copy :: Maybe Variable - } - - -data Content - = FlexVar (Maybe Name.Name) - | FlexSuper SuperType (Maybe Name.Name) - | RigidVar Name.Name - | RigidSuper SuperType Name.Name - | Structure FlatType - | Alias ModuleName.Canonical Name.Name [(Name.Name,Variable)] Variable - | Error - - -data SuperType - = Number - | Comparable - | Appendable - | CompAppend - deriving (Eq) - - -makeDescriptor :: Content -> Descriptor -makeDescriptor content = - Descriptor content noRank noMark Nothing - - - --- RANKS - - -noRank :: Int -noRank = - 0 - - -outermostRank :: Int -outermostRank = - 1 - - - --- MARKS - - -newtype Mark = Mark Word32 - deriving (Eq, Ord) - - -noMark :: Mark -noMark = - Mark 2 - - -occursMark :: Mark -occursMark = - Mark 1 - - -getVarNamesMark :: Mark -getVarNamesMark = - Mark 0 - - -{-# INLINE nextMark #-} -nextMark :: Mark -> Mark -nextMark (Mark mark) = - Mark (mark + 1) - - - --- FUNCTION TYPES - - -infixr 9 ==> - - -{-# INLINE (==>) #-} -(==>) :: Type -> Type -> Type -(==>) = - FunN - - - --- PRIMITIVE TYPES - - -{-# NOINLINE int #-} -int :: Type -int = AppN ModuleName.basics "Int" [] - - -{-# NOINLINE float #-} -float :: Type -float = AppN ModuleName.basics "Float" [] - - -{-# NOINLINE char #-} -char :: Type -char = AppN ModuleName.char "Char" [] - - -{-# NOINLINE string #-} -string :: Type -string = AppN ModuleName.string "String" [] - - -{-# NOINLINE bool #-} -bool :: Type -bool = AppN ModuleName.basics "Bool" [] - - -{-# NOINLINE never #-} -never :: Type -never = AppN ModuleName.basics "Never" [] - - - --- WEBGL TYPES - - -{-# NOINLINE vec2 #-} -vec2 :: Type -vec2 = AppN ModuleName.vector2 "Vec2" [] - - -{-# NOINLINE vec3 #-} -vec3 :: Type -vec3 = AppN ModuleName.vector3 "Vec3" [] - - -{-# NOINLINE vec4 #-} -vec4 :: Type -vec4 = AppN ModuleName.vector4 "Vec4" [] - - -{-# NOINLINE mat4 #-} -mat4 :: Type -mat4 = AppN ModuleName.matrix4 "Mat4" [] - - -{-# NOINLINE texture #-} -texture :: Type -texture = AppN ModuleName.texture "Texture" [] - - - --- MAKE FLEX VARIABLES - - -mkFlexVar :: IO Variable -mkFlexVar = - UF.fresh flexVarDescriptor - - -{-# NOINLINE flexVarDescriptor #-} -flexVarDescriptor :: Descriptor -flexVarDescriptor = - makeDescriptor unnamedFlexVar - - -{-# NOINLINE unnamedFlexVar #-} -unnamedFlexVar :: Content -unnamedFlexVar = - FlexVar Nothing - - - --- MAKE FLEX NUMBERS - - -mkFlexNumber :: IO Variable -mkFlexNumber = - UF.fresh flexNumberDescriptor - - -{-# NOINLINE flexNumberDescriptor #-} -flexNumberDescriptor :: Descriptor -flexNumberDescriptor = - makeDescriptor (unnamedFlexSuper Number) - - -unnamedFlexSuper :: SuperType -> Content -unnamedFlexSuper super = - FlexSuper super Nothing - - - --- MAKE NAMED VARIABLES - - -nameToFlex :: Name.Name -> IO Variable -nameToFlex name = - UF.fresh $ makeDescriptor $ - maybe FlexVar FlexSuper (toSuper name) (Just name) - - -nameToRigid :: Name.Name -> IO Variable -nameToRigid name = - UF.fresh $ makeDescriptor $ - maybe RigidVar RigidSuper (toSuper name) name - - -toSuper :: Name.Name -> Maybe SuperType -toSuper name = - if Name.isNumberType name then - Just Number - - else if Name.isComparableType name then - Just Comparable - - else if Name.isAppendableType name then - Just Appendable - - else if Name.isCompappendType name then - Just CompAppend - - else - Nothing - - - --- TO TYPE ANNOTATION - - -toAnnotation :: Variable -> IO Can.Annotation -toAnnotation variable = - do userNames <- getVarNames variable Map.empty - (tipe, NameState freeVars _ _ _ _ _) <- - State.runStateT (variableToCanType variable) (makeNameState userNames) - return $ Can.Forall freeVars tipe - - -variableToCanType :: Variable -> StateT NameState IO Can.Type -variableToCanType variable = - do (Descriptor content _ _ _) <- liftIO $ UF.get variable - case content of - Structure term -> - termToCanType term - - FlexVar maybeName -> - case maybeName of - Just name -> - return (Can.TVar name) - - Nothing -> - do name <- getFreshVarName - liftIO $ UF.modify variable (\desc -> desc { _content = FlexVar (Just name) }) - return (Can.TVar name) - - FlexSuper super maybeName -> - case maybeName of - Just name -> - return (Can.TVar name) - - Nothing -> - do name <- getFreshSuperName super - liftIO $ UF.modify variable (\desc -> desc { _content = FlexSuper super (Just name) }) - return (Can.TVar name) - - RigidVar name -> - return (Can.TVar name) - - RigidSuper _ name -> - return (Can.TVar name) - - Alias home name args realVariable -> - do canArgs <- traverse (traverse variableToCanType) args - canType <- variableToCanType realVariable - return (Can.TAlias home name canArgs (Can.Filled canType)) - - Error -> - error "cannot handle Error types in variableToCanType" - - -termToCanType :: FlatType -> StateT NameState IO Can.Type -termToCanType term = - case term of - App1 home name args -> - Can.TType home name <$> traverse variableToCanType args - - Fun1 a b -> - Can.TLambda - <$> variableToCanType a - <*> variableToCanType b - - EmptyRecord1 -> - return $ Can.TRecord Map.empty Nothing - - Record1 fields extension -> - do canFields <- traverse fieldToCanType fields - canExt <- Type.iteratedDealias <$> variableToCanType extension - return $ - case canExt of - Can.TRecord subFields subExt -> - Can.TRecord (Map.union subFields canFields) subExt - - Can.TVar name -> - Can.TRecord canFields (Just name) - - _ -> - error "Used toAnnotation on a type that is not well-formed" - - Unit1 -> - return Can.TUnit - - Tuple1 a b maybeC -> - Can.TTuple - <$> variableToCanType a - <*> variableToCanType b - <*> traverse variableToCanType maybeC - - -fieldToCanType :: Variable -> StateT NameState IO Can.FieldType -fieldToCanType variable = - do tipe <- variableToCanType variable - return (Can.FieldType 0 tipe) - - - --- TO ERROR TYPE - - -toErrorType :: Variable -> IO ET.Type -toErrorType variable = - do userNames <- getVarNames variable Map.empty - State.evalStateT (variableToErrorType variable) (makeNameState userNames) - - -variableToErrorType :: Variable -> StateT NameState IO ET.Type -variableToErrorType variable = - do descriptor <- liftIO $ UF.get variable - let mark = _mark descriptor - if mark == occursMark - then - return ET.Infinite - - else - do liftIO $ UF.modify variable (\desc -> desc { _mark = occursMark }) - errType <- contentToErrorType variable (_content descriptor) - liftIO $ UF.modify variable (\desc -> desc { _mark = mark }) - return errType - - -contentToErrorType :: Variable -> Content -> StateT NameState IO ET.Type -contentToErrorType variable content = - case content of - Structure term -> - termToErrorType term - - FlexVar maybeName -> - case maybeName of - Just name -> - return (ET.FlexVar name) - - Nothing -> - do name <- getFreshVarName - liftIO $ UF.modify variable (\desc -> desc { _content = FlexVar (Just name) }) - return (ET.FlexVar name) - - FlexSuper super maybeName -> - case maybeName of - Just name -> - return (ET.FlexSuper (superToSuper super) name) - - Nothing -> - do name <- getFreshSuperName super - liftIO $ UF.modify variable (\desc -> desc { _content = FlexSuper super (Just name) }) - return (ET.FlexSuper (superToSuper super) name) - - RigidVar name -> - return (ET.RigidVar name) - - RigidSuper super name -> - return (ET.RigidSuper (superToSuper super) name) - - Alias home name args realVariable -> - do errArgs <- traverse (traverse variableToErrorType) args - errType <- variableToErrorType realVariable - return (ET.Alias home name errArgs errType) - - Error -> - return ET.Error - - -superToSuper :: SuperType -> ET.Super -superToSuper super = - case super of - Number -> ET.Number - Comparable -> ET.Comparable - Appendable -> ET.Appendable - CompAppend -> ET.CompAppend - - -termToErrorType :: FlatType -> StateT NameState IO ET.Type -termToErrorType term = - case term of - App1 home name args -> - ET.Type home name <$> traverse variableToErrorType args - - Fun1 a b -> - do arg <- variableToErrorType a - result <- variableToErrorType b - return $ - case result of - ET.Lambda arg1 arg2 others -> - ET.Lambda arg arg1 (arg2:others) - - _ -> - ET.Lambda arg result [] - - EmptyRecord1 -> - return $ ET.Record Map.empty ET.Closed - - Record1 fields extension -> - do errFields <- traverse variableToErrorType fields - errExt <- ET.iteratedDealias <$> variableToErrorType extension - return $ - case errExt of - ET.Record subFields subExt -> - ET.Record (Map.union subFields errFields) subExt - - ET.FlexVar ext -> - ET.Record errFields (ET.FlexOpen ext) - - ET.RigidVar ext -> - ET.Record errFields (ET.RigidOpen ext) - - _ -> - error "Used toErrorType on a type that is not well-formed" - - Unit1 -> - return ET.Unit - - Tuple1 a b maybeC -> - ET.Tuple - <$> variableToErrorType a - <*> variableToErrorType b - <*> traverse variableToErrorType maybeC - - - --- MANAGE FRESH VARIABLE NAMES - - -data NameState = - NameState - { _taken :: Map.Map Name.Name () - , _normals :: Int - , _numbers :: Int - , _comparables :: Int - , _appendables :: Int - , _compAppends :: Int - } - - -makeNameState :: Map.Map Name.Name Variable -> NameState -makeNameState taken = - NameState (Map.map (const ()) taken) 0 0 0 0 0 - - - --- FRESH VAR NAMES - - -getFreshVarName :: (Monad m) => StateT NameState m Name.Name -getFreshVarName = - do index <- State.gets _normals - taken <- State.gets _taken - let (name, newIndex, newTaken) = getFreshVarNameHelp index taken - State.modify $ \state -> state { _taken = newTaken, _normals = newIndex } - return name - - -getFreshVarNameHelp :: Int -> Map.Map Name.Name () -> (Name.Name, Int, Map.Map Name.Name ()) -getFreshVarNameHelp index taken = - let - name = - Name.fromTypeVariableScheme index - in - if Map.member name taken then - getFreshVarNameHelp (index + 1) taken - else - ( name, index + 1, Map.insert name () taken ) - - - --- FRESH SUPER NAMES - - -getFreshSuperName :: (Monad m) => SuperType -> StateT NameState m Name.Name -getFreshSuperName super = - case super of - Number -> - getFreshSuper "number" _numbers (\index state -> state { _numbers = index }) - - Comparable -> - getFreshSuper "comparable" _comparables (\index state -> state { _comparables = index }) - - Appendable -> - getFreshSuper "appendable" _appendables (\index state -> state { _appendables = index }) - - CompAppend -> - getFreshSuper "compappend" _compAppends (\index state -> state { _compAppends = index }) - - -getFreshSuper :: (Monad m) => Name.Name -> (NameState -> Int) -> (Int -> NameState -> NameState) -> StateT NameState m Name.Name -getFreshSuper prefix getter setter = - do index <- State.gets getter - taken <- State.gets _taken - let (name, newIndex, newTaken) = getFreshSuperHelp prefix index taken - State.modify (\state -> setter newIndex state { _taken = newTaken }) - return name - - -getFreshSuperHelp :: Name.Name -> Int -> Map.Map Name.Name () -> (Name.Name, Int, Map.Map Name.Name ()) -getFreshSuperHelp prefix index taken = - let - name = - Name.fromTypeVariable prefix index - in - if Map.member name taken then - getFreshSuperHelp prefix (index + 1) taken - - else - ( name, index + 1, Map.insert name () taken ) - - - --- GET ALL VARIABLE NAMES - - -getVarNames :: Variable -> Map.Map Name.Name Variable -> IO (Map.Map Name.Name Variable) -getVarNames var takenNames = - do (Descriptor content rank mark copy) <- UF.get var - if mark == getVarNamesMark - then return takenNames - else - do UF.set var (Descriptor content rank getVarNamesMark copy) - case content of - Error -> - return takenNames - - FlexVar maybeName -> - case maybeName of - Nothing -> - return takenNames - - Just name -> - addName 0 name var (FlexVar . Just) takenNames - - FlexSuper super maybeName -> - case maybeName of - Nothing -> - return takenNames - - Just name -> - addName 0 name var (FlexSuper super . Just) takenNames - - RigidVar name -> - addName 0 name var RigidVar takenNames - - RigidSuper super name -> - addName 0 name var (RigidSuper super) takenNames - - Alias _ _ args _ -> - foldrM getVarNames takenNames (map snd args) - - Structure flatType -> - case flatType of - App1 _ _ args -> - foldrM getVarNames takenNames args - - Fun1 arg body -> - getVarNames arg =<< getVarNames body takenNames - - EmptyRecord1 -> - return takenNames - - Record1 fields extension -> - getVarNames extension =<< - foldrM getVarNames takenNames (Map.elems fields) - - Unit1 -> - return takenNames - - Tuple1 a b Nothing -> - getVarNames a =<< getVarNames b takenNames - - Tuple1 a b (Just c) -> - getVarNames a =<< getVarNames b =<< getVarNames c takenNames - - - --- REGISTER NAME / RENAME DUPLICATES - - -addName :: Int -> Name.Name -> Variable -> (Name.Name -> Content) -> Map.Map Name.Name Variable -> IO (Map.Map Name.Name Variable) -addName index givenName var makeContent takenNames = - let - indexedName = - Name.fromTypeVariable givenName index - in - case Map.lookup indexedName takenNames of - Nothing -> - do if indexedName == givenName then return () else - UF.modify var $ \(Descriptor _ rank mark copy) -> - Descriptor (makeContent indexedName) rank mark copy - return $ Map.insert indexedName var takenNames - - Just otherVar -> - do same <- UF.equivalent var otherVar - if same - then return takenNames - else addName (index + 1) givenName var makeContent takenNames diff --git a/compiler/src/Type/Unify.hs b/compiler/src/Type/Unify.hs deleted file mode 100644 index 837d930e0c..0000000000 --- a/compiler/src/Type/Unify.hs +++ /dev/null @@ -1,695 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE OverloadedStrings, Rank2Types #-} -module Type.Unify - ( Answer(..) - , unify - ) - where - - -import qualified Data.Map.Strict as Map -import qualified Data.Name as Name - -import qualified Elm.ModuleName as ModuleName -import qualified Type.Error as Error -import qualified Type.Occurs as Occurs -import Type.Type as Type -import qualified Type.UnionFind as UF - - - --- UNIFY - - -data Answer - = Ok [Variable] - | Err [Variable] Error.Type Error.Type - - -unify :: Variable -> Variable -> IO Answer -unify v1 v2 = - case guardedUnify v1 v2 of - Unify k -> - k [] onSuccess $ \vars () -> - do t1 <- Type.toErrorType v1 - t2 <- Type.toErrorType v2 - UF.union v1 v2 errorDescriptor - return (Err vars t1 t2) - - -onSuccess :: [Variable] -> () -> IO Answer -onSuccess vars () = - return (Ok vars) - - -{-# NOINLINE errorDescriptor #-} -errorDescriptor :: Descriptor -errorDescriptor = - Descriptor Error noRank noMark Nothing - - - --- CPS UNIFIER - - -newtype Unify a = - Unify (forall r. - [Variable] - -> ([Variable] -> a -> IO r) - -> ([Variable] -> () -> IO r) - -> IO r - ) - - -instance Functor Unify where - fmap func (Unify kv) = - Unify $ \vars ok err -> - let - ok1 vars1 value = - ok vars1 (func value) - in - kv vars ok1 err - - -instance Applicative Unify where - pure a = - Unify $ \vars ok _ -> - ok vars a - - (<*>) (Unify kf) (Unify kv) = - Unify $ \vars ok err -> - let - ok1 vars1 func = - let - ok2 vars2 value = - ok vars2 (func value) - in - kv vars1 ok2 err - in - kf vars ok1 err - - -instance Monad Unify where - return a = - Unify $ \vars ok _ -> - ok vars a - - (>>=) (Unify ka) callback = - Unify $ \vars ok err -> - let - ok1 vars1 a = - case callback a of - Unify kb -> kb vars1 ok err - in - ka vars ok1 err - - (>>) (Unify ka) (Unify kb) = - Unify $ \vars ok err -> - let - ok1 vars1 _ = kb vars1 ok err - in - ka vars ok1 err - - -register :: IO Variable -> Unify Variable -register mkVar = - Unify $ \vars ok _ -> - do var <- mkVar - ok (var:vars) var - - -mismatch :: Unify a -mismatch = - Unify $ \vars _ err -> - err vars () - - - --- UNIFICATION HELPERS - - -data Context = - Context - { _first :: Variable - , _firstDesc :: Descriptor - , _second :: Variable - , _secondDesc :: Descriptor - } - - -reorient :: Context -> Context -reorient (Context var1 desc1 var2 desc2) = - Context var2 desc2 var1 desc1 - - - --- MERGE - - -merge :: Context -> Content -> Unify () -merge (Context var1 (Descriptor _ rank1 _ _) var2 (Descriptor _ rank2 _ _)) content = - Unify $ \vars ok _ -> - ok vars =<< - UF.union var1 var2 (Descriptor content (min rank1 rank2) noMark Nothing) - - -fresh :: Context -> Content -> Unify Variable -fresh (Context _ (Descriptor _ rank1 _ _) _ (Descriptor _ rank2 _ _)) content = - register $ UF.fresh $ - Descriptor content (min rank1 rank2) noMark Nothing - - - --- ACTUALLY UNIFY THINGS - - -guardedUnify :: Variable -> Variable -> Unify () -guardedUnify left right = - Unify $ \vars ok err -> - do equivalent <- UF.equivalent left right - if equivalent - then ok vars () - else - do leftDesc <- UF.get left - rightDesc <- UF.get right - case actuallyUnify (Context left leftDesc right rightDesc) of - Unify k -> - k vars ok err - - -subUnify :: Variable -> Variable -> Unify () -subUnify var1 var2 = - guardedUnify var1 var2 - - -actuallyUnify :: Context -> Unify () -actuallyUnify context@(Context _ (Descriptor firstContent _ _ _) _ (Descriptor secondContent _ _ _)) = - case firstContent of - FlexVar _ -> - unifyFlex context firstContent secondContent - - FlexSuper super _ -> - unifyFlexSuper context super firstContent secondContent - - RigidVar _ -> - unifyRigid context Nothing firstContent secondContent - - RigidSuper super _ -> - unifyRigid context (Just super) firstContent secondContent - - Alias home name args realVar -> - unifyAlias context home name args realVar secondContent - - Structure flatType -> - unifyStructure context flatType firstContent secondContent - - Error -> - -- If there was an error, just pretend it is okay. This lets us avoid - -- "cascading" errors where one problem manifests as multiple message. - merge context Error - - - --- UNIFY FLEXIBLE VARIABLES - - -unifyFlex :: Context -> Content -> Content -> Unify () -unifyFlex context content otherContent = - case otherContent of - Error -> - merge context Error - - FlexVar maybeName -> - merge context $ - case maybeName of - Nothing -> - content - - Just _ -> - otherContent - - FlexSuper _ _ -> - merge context otherContent - - RigidVar _ -> - merge context otherContent - - RigidSuper _ _ -> - merge context otherContent - - Alias _ _ _ _ -> - merge context otherContent - - Structure _ -> - merge context otherContent - - - --- UNIFY RIGID VARIABLES - - -unifyRigid :: Context -> Maybe SuperType -> Content -> Content -> Unify () -unifyRigid context maybeSuper content otherContent = - case otherContent of - FlexVar _ -> - merge context content - - FlexSuper otherSuper _ -> - case maybeSuper of - Just super -> - if combineRigidSupers super otherSuper then - merge context content - else - mismatch - - Nothing -> - mismatch - - RigidVar _ -> - mismatch - - RigidSuper _ _ -> - mismatch - - Alias _ _ _ _ -> - mismatch - - Structure _ -> - mismatch - - Error -> - merge context Error - - - --- UNIFY SUPER VARIABLES - - -unifyFlexSuper :: Context -> SuperType -> Content -> Content -> Unify () -unifyFlexSuper context super content otherContent = - case otherContent of - Structure flatType -> - unifyFlexSuperStructure context super flatType - - RigidVar _ -> - mismatch - - RigidSuper otherSuper _ -> - if combineRigidSupers otherSuper super then - merge context otherContent - else - mismatch - - FlexVar _ -> - merge context content - - FlexSuper otherSuper _ -> - case super of - Number -> - case otherSuper of - Number -> merge context content - Comparable -> merge context content - Appendable -> mismatch - CompAppend -> mismatch - - Comparable -> - case otherSuper of - Comparable -> merge context otherContent - Number -> merge context otherContent - Appendable -> merge context (Type.unnamedFlexSuper CompAppend) - CompAppend -> merge context otherContent - - Appendable -> - case otherSuper of - Appendable -> merge context otherContent - Comparable -> merge context (Type.unnamedFlexSuper CompAppend) - CompAppend -> merge context otherContent - Number -> mismatch - - CompAppend -> - case otherSuper of - Comparable -> merge context content - Appendable -> merge context content - CompAppend -> merge context content - Number -> mismatch - - Alias _ _ _ realVar -> - subUnify (_first context) realVar - - Error -> - merge context Error - - -combineRigidSupers :: SuperType -> SuperType -> Bool -combineRigidSupers rigid flex = - rigid == flex - || (rigid == Number && flex == Comparable) - || (rigid == CompAppend && (flex == Comparable || flex == Appendable)) - - -atomMatchesSuper :: SuperType -> ModuleName.Canonical -> Name.Name -> Bool -atomMatchesSuper super home name = - case super of - Number -> - isNumber home name - - Comparable -> - isNumber home name - || Error.isString home name - || Error.isChar home name - - Appendable -> - Error.isString home name - - CompAppend -> - Error.isString home name - - -isNumber :: ModuleName.Canonical -> Name.Name -> Bool -isNumber home name = - home == ModuleName.basics - && - (name == Name.int || name == Name.float) - - -unifyFlexSuperStructure :: Context -> SuperType -> FlatType -> Unify () -unifyFlexSuperStructure context super flatType = - case flatType of - App1 home name [] -> - if atomMatchesSuper super home name then - merge context (Structure flatType) - else - mismatch - - App1 home name [variable] | home == ModuleName.list && name == Name.list -> - case super of - Number -> - mismatch - - Appendable -> - merge context (Structure flatType) - - Comparable -> - do comparableOccursCheck context - unifyComparableRecursive variable - merge context (Structure flatType) - - CompAppend -> - do comparableOccursCheck context - unifyComparableRecursive variable - merge context (Structure flatType) - - Tuple1 a b maybeC -> - case super of - Number -> - mismatch - - Appendable -> - mismatch - - Comparable -> - do comparableOccursCheck context - unifyComparableRecursive a - unifyComparableRecursive b - case maybeC of - Nothing -> return () - Just c -> unifyComparableRecursive c - merge context (Structure flatType) - - CompAppend -> - mismatch - - _ -> - mismatch - - --- TODO: is there some way to avoid doing this? --- Do type classes require occurs checks? -comparableOccursCheck :: Context -> Unify () -comparableOccursCheck (Context _ _ var _) = - Unify $ \vars ok err -> - do hasOccurred <- Occurs.occurs var - if hasOccurred - then err vars () - else ok vars () - - -unifyComparableRecursive :: Variable -> Unify () -unifyComparableRecursive var = - do compVar <- register $ - do (Descriptor _ rank _ _) <- UF.get var - UF.fresh $ Descriptor (Type.unnamedFlexSuper Comparable) rank noMark Nothing - guardedUnify compVar var - - - --- UNIFY ALIASES - - -unifyAlias :: Context -> ModuleName.Canonical -> Name.Name -> [(Name.Name, Variable)] -> Variable -> Content -> Unify () -unifyAlias context home name args realVar otherContent = - case otherContent of - FlexVar _ -> - merge context (Alias home name args realVar) - - FlexSuper _ _ -> - subUnify realVar (_second context) - - RigidVar _ -> - subUnify realVar (_second context) - - RigidSuper _ _ -> - subUnify realVar (_second context) - - Alias otherHome otherName otherArgs otherRealVar -> - if name == otherName && home == otherHome then - Unify $ \vars ok err -> - let - ok1 vars1 () = - case merge context otherContent of - Unify k -> - k vars1 ok err - in - unifyAliasArgs vars context args otherArgs ok1 err - - else - subUnify realVar otherRealVar - - Structure _ -> - subUnify realVar (_second context) - - Error -> - merge context Error - - -unifyAliasArgs :: [Variable] -> Context -> [(Name.Name,Variable)] -> [(Name.Name,Variable)] -> ([Variable] -> () -> IO r) -> ([Variable] -> () -> IO r) -> IO r -unifyAliasArgs vars context args1 args2 ok err = - case args1 of - (_,arg1):others1 -> - case args2 of - (_,arg2):others2 -> - case subUnify arg1 arg2 of - Unify k -> - k vars - (\vs () -> unifyAliasArgs vs context others1 others2 ok err) - (\vs () -> unifyAliasArgs vs context others1 others2 err err) - - _ -> - err vars () - - [] -> - case args2 of - [] -> - ok vars () - - _ -> - err vars () - - - --- UNIFY STRUCTURES - - -unifyStructure :: Context -> FlatType -> Content -> Content -> Unify () -unifyStructure context flatType content otherContent = - case otherContent of - FlexVar _ -> - merge context content - - FlexSuper super _ -> - unifyFlexSuperStructure (reorient context) super flatType - - RigidVar _ -> - mismatch - - RigidSuper _ _ -> - mismatch - - Alias _ _ _ realVar -> - subUnify (_first context) realVar - - Structure otherFlatType -> - case (flatType, otherFlatType) of - (App1 home name args, App1 otherHome otherName otherArgs) | home == otherHome && name == otherName -> - Unify $ \vars ok err -> - let - ok1 vars1 () = - case merge context otherContent of - Unify k -> - k vars1 ok err - in - unifyArgs vars context args otherArgs ok1 err - - (Fun1 arg1 res1, Fun1 arg2 res2) -> - do subUnify arg1 arg2 - subUnify res1 res2 - merge context otherContent - - (EmptyRecord1, EmptyRecord1) -> - merge context otherContent - - (Record1 fields ext, EmptyRecord1) | Map.null fields -> - subUnify ext (_second context) - - (EmptyRecord1, Record1 fields ext) | Map.null fields -> - subUnify (_first context) ext - - (Record1 fields1 ext1, Record1 fields2 ext2) -> - Unify $ \vars ok err -> - do structure1 <- gatherFields fields1 ext1 - structure2 <- gatherFields fields2 ext2 - case unifyRecord context structure1 structure2 of - Unify k -> - k vars ok err - - (Tuple1 a b Nothing, Tuple1 x y Nothing) -> - do subUnify a x - subUnify b y - merge context otherContent - - (Tuple1 a b (Just c), Tuple1 x y (Just z)) -> - do subUnify a x - subUnify b y - subUnify c z - merge context otherContent - - (Unit1, Unit1) -> - merge context otherContent - - _ -> - mismatch - - Error -> - merge context Error - - - --- UNIFY ARGS - - -unifyArgs :: [Variable] -> Context -> [Variable] -> [Variable] -> ([Variable] -> () -> IO r) -> ([Variable] -> () -> IO r) -> IO r -unifyArgs vars context args1 args2 ok err = - case args1 of - arg1:others1 -> - case args2 of - arg2:others2 -> - case subUnify arg1 arg2 of - Unify k -> - k vars - (\vs () -> unifyArgs vs context others1 others2 ok err) - (\vs () -> unifyArgs vs context others1 others2 err err) - - _ -> - err vars () - - [] -> - case args2 of - [] -> - ok vars () - - _ -> - err vars () - - - --- UNIFY RECORDS - - -unifyRecord :: Context -> RecordStructure -> RecordStructure -> Unify () -unifyRecord context (RecordStructure fields1 ext1) (RecordStructure fields2 ext2) = - let - sharedFields = Map.intersectionWith (,) fields1 fields2 - uniqueFields1 = Map.difference fields1 fields2 - uniqueFields2 = Map.difference fields2 fields1 - in - if Map.null uniqueFields1 then - - if Map.null uniqueFields2 then - do subUnify ext1 ext2 - unifySharedFields context sharedFields Map.empty ext1 - - else - do subRecord <- fresh context (Structure (Record1 uniqueFields2 ext2)) - subUnify ext1 subRecord - unifySharedFields context sharedFields Map.empty subRecord - - else - - if Map.null uniqueFields2 then - do subRecord <- fresh context (Structure (Record1 uniqueFields1 ext1)) - subUnify subRecord ext2 - unifySharedFields context sharedFields Map.empty subRecord - - else - do let otherFields = Map.union uniqueFields1 uniqueFields2 - ext <- fresh context Type.unnamedFlexVar - sub1 <- fresh context (Structure (Record1 uniqueFields1 ext)) - sub2 <- fresh context (Structure (Record1 uniqueFields2 ext)) - subUnify ext1 sub2 - subUnify sub1 ext2 - unifySharedFields context sharedFields otherFields ext - - -unifySharedFields :: Context -> Map.Map Name.Name (Variable, Variable) -> Map.Map Name.Name Variable -> Variable -> Unify () -unifySharedFields context sharedFields otherFields ext = - do matchingFields <- Map.traverseMaybeWithKey unifyField sharedFields - if Map.size sharedFields == Map.size matchingFields - then merge context (Structure (Record1 (Map.union matchingFields otherFields) ext)) - else mismatch - - -unifyField :: Name.Name -> (Variable, Variable) -> Unify (Maybe Variable) -unifyField _ (actual, expected) = - Unify $ \vars ok _ -> - case subUnify actual expected of - Unify k -> - k vars - (\vs () -> ok vs (Just actual)) - (\vs () -> ok vs Nothing) - - - --- GATHER RECORD STRUCTURE - - -data RecordStructure = - RecordStructure - { _fields :: Map.Map Name.Name Variable - , _extension :: Variable - } - - -gatherFields :: Map.Map Name.Name Variable -> Variable -> IO RecordStructure -gatherFields fields variable = - do (Descriptor content _ _ _) <- UF.get variable - case content of - Structure (Record1 subFields subExt) -> - gatherFields (Map.union fields subFields) subExt - - Alias _ _ _ var -> - -- TODO may be dropping useful alias info here - gatherFields fields var - - _ -> - return (RecordStructure fields variable) - diff --git a/compiler/src/Type/UnionFind.hs b/compiler/src/Type/UnionFind.hs deleted file mode 100644 index 31fbab160c..0000000000 --- a/compiler/src/Type/UnionFind.hs +++ /dev/null @@ -1,172 +0,0 @@ -{-# OPTIONS_GHC -funbox-strict-fields #-} -{-# LANGUAGE BangPatterns #-} -module Type.UnionFind - ( Point - , fresh - , union - , equivalent - , redundant - , get - , set - , modify - ) - where - - -{- This is based on the following implementations: - - - https://hackage.haskell.org/package/union-find-0.2/docs/src/Data-UnionFind-IO.html - - http://yann.regis-gianas.org/public/mini/code_UnionFind.html - -It seems like the OCaml one came first, but I am not sure. - -Compared to the Haskell implementation, the major changes here include: - - 1. No more reallocating PointInfo when changing the weight - 2. Using the strict modifyIORef - --} - - -import Control.Monad ( when ) -import Data.IORef (IORef, modifyIORef', newIORef, readIORef, writeIORef) -import Data.Word (Word32) - - - --- POINT - - -newtype Point a = - Pt (IORef (PointInfo a)) - deriving Eq - - -data PointInfo a - = Info {-# UNPACK #-} !(IORef Word32) {-# UNPACK #-} !(IORef a) - | Link {-# UNPACK #-} !(Point a) - - - --- HELPERS - - -fresh :: a -> IO (Point a) -fresh value = - do weight <- newIORef 1 - desc <- newIORef value - link <- newIORef (Info weight desc) - return (Pt link) - - -repr :: Point a -> IO (Point a) -repr point@(Pt ref) = - do pInfo <- readIORef ref - case pInfo of - Info _ _ -> - return point - - Link point1@(Pt ref1) -> - do point2 <- repr point1 - when (point2 /= point1) $ - do pInfo1 <- readIORef ref1 - writeIORef ref pInfo1 - return point2 - - -get :: Point a -> IO a -get point@(Pt ref) = - do pInfo <- readIORef ref - case pInfo of - Info _ descRef -> - readIORef descRef - - Link (Pt ref1) -> - do link' <- readIORef ref1 - case link' of - Info _ descRef -> - readIORef descRef - - Link _ -> - get =<< repr point - - -set :: Point a -> a -> IO () -set point@(Pt ref) newDesc = - do pInfo <- readIORef ref - case pInfo of - Info _ descRef -> - writeIORef descRef newDesc - - Link (Pt ref1) -> - do link' <- readIORef ref1 - case link' of - Info _ descRef -> - writeIORef descRef newDesc - - Link _ -> - do newPoint <- repr point - set newPoint newDesc - - -modify :: Point a -> (a -> a) -> IO () -modify point@(Pt ref) func = - do pInfo <- readIORef ref - case pInfo of - Info _ descRef -> - modifyIORef' descRef func - - Link (Pt ref1) -> - do link' <- readIORef ref1 - case link' of - Info _ descRef -> - modifyIORef' descRef func - - Link _ -> - do newPoint <- repr point - modify newPoint func - - -union :: Point a -> Point a -> a -> IO () -union p1 p2 newDesc = - do point1@(Pt ref1) <- repr p1 - point2@(Pt ref2) <- repr p2 - - Info w1 d1 <- readIORef ref1 - Info w2 d2 <- readIORef ref2 - - if point1 == point2 - then writeIORef d1 newDesc - else do - weight1 <- readIORef w1 - weight2 <- readIORef w2 - - let !newWeight = weight1 + weight2 - - if weight1 >= weight2 - then - do writeIORef ref2 (Link point1) - writeIORef w1 newWeight - writeIORef d1 newDesc - else - do writeIORef ref1 (Link point2) - writeIORef w2 newWeight - writeIORef d2 newDesc - - -equivalent :: Point a -> Point a -> IO Bool -equivalent p1 p2 = - do v1 <- repr p1 - v2 <- repr p2 - return (v1 == v2) - - -redundant :: Point a -> IO Bool -redundant (Pt ref) = - do pInfo <- readIORef ref - case pInfo of - Info _ _ -> - return False - - Link _ -> - return True diff --git a/docs/elm.json/application.md b/docs/elm.json/application.md deleted file mode 100644 index 4dc0c80577..0000000000 --- a/docs/elm.json/application.md +++ /dev/null @@ -1,69 +0,0 @@ -# `elm.json` for applications - -This is a decent baseline for pretty much any applications made with Elm. You will need these dependencies or more. - -```json -{ - "type": "application", - "source-directories": [ - "src" - ], - "elm-version": "0.19.0", - "dependencies": { - "direct": { - "elm/browser": "1.0.0", - "elm/core": "1.0.0", - "elm/html": "1.0.0", - "elm/json": "1.0.0" - }, - "indirect": { - "elm/time": "1.0.0", - "elm/url": "1.0.0", - "elm/virtual-dom": "1.0.0" - } - }, - "test-dependencies": { - "direct": {}, - "indirect": {} - } -} -``` - -
- - -## `"type"` - -Either `"application"` or `"package"`. All the other fields are based on this choice! - -
- - -## `"source-directories"` - -A list of directories where Elm code lives. Most projects just use `"src"` for everything. - -
- - -## `"elm-version"` - -The exact version of Elm this builds with. Should be `"0.19.0"` for most people! - -
- - -## `"dependencies"` - -All the packages you depend upon. We use exact versions, so your `elm.json` file doubles as a "lock file" that ensures reliable builds. - -You can use modules from any `"direct"` dependency in your code. Some `"direct"` dependencies have their own dependencies that folks typically do not care about. These are the `"indirect"` dependencies. They are listed explicitly so that (1) builds are reproducible and (2) you can easily review the quantity and quality of dependencies. - -**Note:** We plan to eventually have a screen in `reactor` that helps add, remove, and upgrade packages. It can sometimes be tricky to keep all of the constraints happy, so we think having a UI will help a lot. If you get into trouble in the meantime, adding things back one-by-one often helps, and I hope you do not get into trouble! - -
- - -## `"test-dependencies"` - -All the packages that you use in `tests/` with `elm-test` but not in the application you actually want to ship. This also uses exact versions to make tests more reliable. diff --git a/docs/elm.json/package.md b/docs/elm.json/package.md deleted file mode 100644 index 6432cde42e..0000000000 --- a/docs/elm.json/package.md +++ /dev/null @@ -1,93 +0,0 @@ -# `elm.json` for packages - -This is roughly `elm.json` for the `elm/json` package: - -```json -{ - "type": "package", - "name": "elm/json", - "summary": "Encode and decode JSON values", - "license": "BSD-3-Clause", - "version": "1.0.0", - "exposed-modules": [ - "Json.Decode", - "Json.Encode" - ], - "elm-version": "0.19.0 <= v < 0.20.0", - "dependencies": { - "elm/core": "1.0.0 <= v < 2.0.0" - }, - "test-dependencies": {} -} -``` - -
- - -## `"type"` - -Either `"application"` or `"package"`. All the other fields are based on this choice. - -
- - -## `"name"` - -The name of a GitHub repo like `"elm-lang/core"` or `"rtfeldman/elm-css"`. - -> **Note:** We currently only support GitHub repos to ensure that there are no author name collisions. This seems like a pretty tricky problem to solve in a pleasant way. For example, do we have to keep an author name registry and give them out as we see them? But if someone is the same person on two platforms? And how to make this all happen in a way this is really nice for typical Elm users? Etc. So adding other hosting endpoints is harder than it sounds. - -
- - -## `"summary"` - -A short summary that will appear on [`package.elm-lang.org`](https://package.elm-lang.org/) that describes what the package is for. Must be under 80 characters. - -
- - -## `"license"` - -An OSI approved SPDX code like `"BSD-3-Clause"` or `"MIT"`. These are the two most common licenses in the Elm ecosystem, but you can see the full list of options [here](https://spdx.org/licenses/). - -
- - -## `"version"` - -All packages start at `"1.0.0"` and from there, Elm automatically enforces semantic versioning by comparing API changes. - -So if you make a PATCH change and call `elm bump` it will update you to `"1.0.1"`. And if you then decide to remove a function (a MAJOR change) and call `elm bump` it will update you to `"2.0.0"`. Etc. - -
- - -## `"exposed-modules"` - -A list of modules that will be exposed to people using your package. The order you list them will be the order they appear on [`package.elm-lang.org`](https://package.elm-lang.org/). - -**Note:** If you have five or more modules, you can use a labelled list like [this](https://github.com/elm-lang/core/blob/master/elm.json). We show the labels on the package website to help people sort through larger packages with distinct categories. Labels must be under 20 characters. - -
- - -## `"elm-version"` - -The range of Elm compilers that work with your package. Right now `"0.19.0 <= v < 0.20.0"` is always what you want for this. - -
- - -## `"dependencies"` - -A list of packages that you depend upon. In each application, there can only be one version of each package, so wide ranges are great. Fewer dependencies is even better though! - -> **Note:** Dependency ranges should only express _tested_ ranges. It is not nice to use optimistic ranges and end up causing build failures for your users down the line. Eventually we would like to have an automated system that tries to build and test packages as new packages come out. If it all works, we could send a PR to the author widening the range. - -
- - -## `"test-dependencies"` - -Dependencies that are only used in the `tests/` directory by `elm test`. Values from these packages will not appear in any final build artifacts. diff --git a/docs/upgrade-instructions/0.16.md b/docs/upgrade-instructions/0.16.md deleted file mode 100644 index 3f5d267838..0000000000 --- a/docs/upgrade-instructions/0.16.md +++ /dev/null @@ -1,174 +0,0 @@ -# Upgrading to 0.16 - -Upgrading should be pretty easy. Everything is quite mechanical, so I would not be very afraid of this process. - - -## Update elm-package.json - -First thing you want to do is update your `elm-package.json` file. The fields that need work are `repository`, `elm-version`, and `dependencies`. - -If you have some dummy information in `repository`, something like `https://github.com/USER/PROJECT.git`, you will need to change it such that the project is all lower case. This should work: `https://github.com/user/project.git`. - -Here is a working `elm-version`: - -```json -{ - "elm-version": "0.16.0 <= v < 0.17.0" -} -``` - -Here are the latest bounds for a bunch of `dependencies`. - -```json -{ - "dependencies": { - "elm-lang/core": "3.0.0 <= v < 4.0.0", - "evancz/elm-effects": "2.0.1 <= v < 3.0.0", - "evancz/elm-html": "4.0.2 <= v < 5.0.0", - "evancz/elm-http": "3.0.0 <= v < 4.0.0", - "evancz/elm-markdown": "2.0.0 <= v < 3.0.0", - "evancz/elm-svg": "2.0.1 <= v < 3.0.0", - "evancz/start-app": "2.0.2 <= v < 3.0.0" - }, -} -``` - -The easiest way to get this all set up is to remove everything from `dependencies` and just install the things you need one at a time with `elm-package install`. - - -## Updating Syntax - -The major syntax changes are: - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
feature0.15.10.16
field update
{ record | x <- 42 }
{ record | x = 42 }
field addition
{ record | x = 42 }
removed
field deletion
{ record - x }
removed
record constructors that add fields -
-type alias Named r =
-  { r | name : String }
-  
--- generates a function like this:
--- Named : String -> r -> Named r
-
- 		-
-type alias Named r =
-  { r | name : String }
-
-Generates no function. Field addition is gone. A function -will still be generated for "closed" records though. -
field parameters -
-type alias Foo =
-  { prefix : String -> String }
-
-foo : Foo
-foo = { prefix x = "prefix" ++ x }
-
- 		-
-type alias Foo =
-  { prefix : String -> String }
-
-foo : Foo
-foo = { prefix = \x-> "prefix" ++ x }
-
multi-way if -
-if | x < 0 -> "left"
-   | x > 0 -> "right"
-   | otherwise -> "neither"
-
- 		-
-if x < 0 then
-    "left"
-
-else if x > 0 then
-    "right"
-
-else
-    "neither"
-
-
- -The most common by far should be the record update change. That was the only syntax that used the `<-` operator, so you can pretty safely do a find-and-replace from `<-` to `=` and be all set. - -The multi-way if is also pretty easy. You just translate it into the equivalent `if/then/else` construct. As you are doing this, notice the style used. It should look quite a bit like Python or any C-like language really. You start with an `if` and do `else if` until you are done. The body of each branch should be indented and things look way nicer if you have a blank line between each branch. I sometimes put a blank line above and below each branch, especially when the branch is more complex. - -If you are using field addition and deletion, it is possible to translate your code into: - - 1. A union type that models things with a simpler API, like [in this case](https://github.com/elm-lang/elm-compiler/issues/985#issuecomment-121927230). - 2. Nesting records instead of adding things onto them. Rather than adding a field, create an outer record that contains a field for the two things you are trying to put together. This seems to lead to nicer code in the long run. - - -## Incomplete Pattern Matches - -As of 0.16, incomplete pattern matches are caught at compile time as errors. This is true both of `case` expressions and function arguments. - -As I updated things, I ran into this only when I had been tricky with `Maybe` and `List` where I knew something about their structure based on some incidental details. The nicest example of this was [some code in package.elm-lang.org](https://gist.github.com/evancz/e590750a5bd1ea04c2d2) where the priority has often been "get it working" over "excellent quality code". - -The compiler should give you pretty nice hints in all these cases, so I think the best advice is just to expect this sort of thing and treat it as an oppurtunity to clean your code up a bit where you were being tricky. - - -## Updating Library Usages - -There is not actually a lot that changed in `elm-lang/core` and in `evancz/*` libraries. - -The most noticable removals will be: - - * `Basics.otherwise` - * `Signal.(<~)` - * `Signal.(~)` - -`otherwise` is gone because it is very useless without the multi-way if syntax. - -Removing `(<~)` and `(~)` is in the spirit of "infix functions should be avoided" and the overall move towards removing redundant and ugly syntax in this release. You can instead use `Signal.mapN` to fill the void here. If you are combining a ton of signals, you can redefine the equivalent of `(~)` like this: - -```elm -andMap : Signal (a -> b) -> Signal a -> Signal b -andMap = - Signal.map2 (<|) -``` - -Otherwise it is pretty much all small bug fixes and improvements to documentation. diff --git a/docs/upgrade-instructions/0.17.md b/docs/upgrade-instructions/0.17.md deleted file mode 100644 index 1a3bd7ddab..0000000000 --- a/docs/upgrade-instructions/0.17.md +++ /dev/null @@ -1,275 +0,0 @@ - -# Upgrading to 0.17 - -Upgrading should be pretty easy. Everything is quite mechanical, so I would not be very afraid of this process. - - -## Update elm-package.json - -Some core packages have been renamed: - - - `evancz/elm-html` is now `elm-lang/html` - - `evancz/elm-svg` is now `elm-lang/svg` - - `evancz/virtual-dom` is now `elm-lang/virtual-dom` - - The functionality of `evancz/start-app` now lives in `elm-lang/html` in `Html.App` - - The functionality of `evancz/elm-effects` now lives in `elm-lang/core` in `Platform.*` - - The functionality of `Graphics.*` now lives in `evancz/elm-graphics` - -So the first thing you want to do is update your `elm-package.json` file. Here is one that has been properly updated: - -```json -{ - "version": "1.0.0", - "summary": "let people do a cool thing in a fun way", - "repository": "https://github.com/user/project.git", - "license": "BSD3", - "source-directories": [ - "src" - ], - "exposed-modules": [], - "dependencies": { - "elm-lang/core": "4.0.0 <= v < 5.0.0", - "elm-lang/html": "1.0.0 <= v < 2.0.0", - "evancz/elm-http": "3.0.1 <= v < 4.0.0", - "evancz/elm-markdown": "3.0.0 <= v < 4.0.0" - }, - "elm-version": "0.17.0 <= v < 0.18.0" -} -``` - -The only changes should be in the `dependencies` and `elm-version` fields where you need to update constraints. The easiest way to get this all set up is to update `elm-version` by hand, and then remove everything from `dependencies` so you can install the dependencies you still need one at a time with `elm package install`. - - -## Updating Syntax - -The major syntax changes are: - - - - - - - - - - - - - - -
feature0.160.17
module declaration
module Queue (..) where
module Queue exposing (..)
- -This is a super easy change, so we will add a link to an auto-upgrade tool here when one exists. - - -## `Action` is now `Msg` - -The Elm Architecture tutorial uses the term `Action` for the data that gets fed into your `update` function. This is a silly name. So in 0.17 the standard name is *message*. - -```elm --- 0.16 -type Action = Increment | Decrement - --- 0.17 -type Msg = Increment | Decrement -``` - -The idea is that your app is receiving *messages* from the user, from servers, from the browser, etc. Your app then reacts to these messages in the `update` function. - - -## No More `Signal.Address` - -The most common thing in your code will probably be that `Signal.Address` no longer exists. Here is a before and after of upgrading some typical `view` code. - -```elm --- 0.16 -view : Signal.Address Action -> Model -> Html -view address model = - div [] - [ button [ onClick address Decrement ] [ text "-" ] - , div [ countStyle ] [ text (toString model) ] - , button [ onClick address Increment ] [ text "+" ] - ] - --- 0.17 -view : Model -> Html Msg -view model = - div [] - [ button [ onClick Decrement ] [ text "-" ] - , div [ countStyle ] [ text (toString model) ] - , button [ onClick Increment ] [ text "+" ] - ] -``` - -This change is pretty simple. Any occurance of `address` just gets deleted. In the types, you see the addresses removed, and `Html` becomes `Html Msg`. You can read `Html Msg` as "an HTML node that can produce messages of type `Msg`". This change makes addresses unnecessary and makes it much clearer what kind of messages can be produced by a particular block of HTML. - -The `Signal.forwardTo` function is replaced by `Html.App.map`. So you may need to make changes like this: - -```elm --- 0.16 -view : Signal.Address Action -> Model -> Html -view address model = - div [] - [ Counter.view (Signal.forwardTo address Top) model.topCounter - , Counter.view (Signal.forwardTo address Bottom) model.bottomCounter - , button [ onClick address Reset ] [ text "RESET" ] - ] - --- 0.17 -view : Model -> Html Msg -view model = - div [] - [ map Top (Counter.view model.topCounter) - , map Bottom (Counter.view model.bottomCounter) - , button [ onClick Reset ] [ text "RESET" ] - ] -``` - -These changes are nice for a couple really good reasons: - - - Addresses were consistently one of the things that new folks found most confusing. - - It allows the `elm-lang/virtual-dom` implementation to be more efficient with `lazy` - - It uses a normal `map` instead of some unfamiliar API. - -You can see more examples of the new HTML API [here](https://evancz.gitbooks.io/an-introduction-to-elm/content/architecture/user_input/index.html). - - -## `Effects` is now `Cmd` - -If you are working with HTTP or anything, you are probably using `evancz/elm-effects` and have your `update` function returning `Effects` values. That library was a successful experiment, so it has been folded into `elm-lang/core` and given a name that works better in the context of Elm 0.17. - -The changes are basically a simple rename: - -```elm --- 0.16 -update : Action -> Model -> (Model, Effects Action) -update action model = - case action of - RequestMore -> - (model, getRandomGif model.topic) - - NewGif maybeUrl -> - ( Model model.topic (Maybe.withDefault model.gifUrl maybeUrl) - , Effects.none - ) - --- 0.17 -update : Msg -> Model -> (Model, Cmd Msg) -update msg model = - case msg of - RequestMore -> - ( model, getRandomGif model.topic ) - - NewGif maybeUrl -> - ( Model model.topic (Maybe.withDefault model.gifUrl maybeUrl) - , Cmd.none - ) -``` - -The `Cmd` stuff lives in `elm-lang/core` in `Platform.Cmd`. It is imported by default with `import Platform.Cmd as Cmd exposing (Cmd)` to make it easier to use. - -Again, very easy changes. The key goal of 0.17 was to manage effects in a nicer way, so in making these facilities more complete, the term `Effects` became very ambiguous. You should read more about this in the updated Elm Architecture Tutorial which has [a section all about effects](https://evancz.gitbooks.io/an-introduction-to-elm/content/architecture/effects/index.html). - - -## `StartApp` is now `Html.App` - -The `evancz/start-app` package was an experiment to help people get productive with Elm more quickly. It meant that newcomers could get really far with Elm without knowing a ton about signals, and it has been very effective. With 0.17, it has been folded in to `elm-lang/html` in the `Html.App` module. - -Upgrading looks like this: - -```elm --- 0.16 --------------------------------------- -import StartApp -import Task - -app = - StartApp.start - { init = init, update = update, view = view, inputs = [] } - -main = - app.html - -port tasks : Signal (Task.Task Never ()) -port tasks = - app.tasks - --- 0.17 --------------------------------------- -import Html.App as Html - -main = - Html.program - { init = init, update = update, view = view, subscriptions = \_ -> Sub.none } -``` - -The type of `main` has changed from `Signal Html` to `Program flags`. The main value is a program that knows exactly how it needs to be set up. All that will be handled by Elm, so you no longer need to specially hook tasks up to a port or anything. - - -## Upgrading Ports - -Talking to JavaScript still uses ports. It is pretty similar, but adapted to fit nicely with commands and subscriptions. - -Here is the change for *outgoing* ports: - -```elm --- 0.16 -port focus : Signal String -port focus = - ... - --- 0.17 -port focus : String -> Cmd msg -``` - -Instead of hooking up a signal, you have a function that can create commands. So you just call `focus : String -> Cmd msg` from anywhere in your app and the command is processed like all the others. - -And here is the change for *incoming* ports: - -```elm -type User = { name : String, age : Int } - --- 0.16 -port users : Signal User - --- 0.17 -port users : (User -> msg) -> Sub msg -``` - -Instead of getting a signal to route to the right place, we now can create subscriptions to incoming ports. So wherever you need to know about users, you just subscribe to it. - -You should definitely read more about this [here](https://evancz.gitbooks.io/an-introduction-to-elm/content/interop/javascript.html). - - -## JavaScript Interop - -The style of initializing Elm programs in JS has also changed slightly. - - - - - - - - - - - - - - - - - - - - - - - - - -
Initialize0.160.17
Embed
Elm.embed(Elm.Main, someNode);
Elm.Main.embed(someNode);
Fullscreen
Elm.fullscreen(Elm.Main);
Elm.Main.fullscreen();
Worker
Elm.worker(Elm.Main);
Elm.Main.worker();
- - -## Next Steps - -From here, I would highly recommend looking through [guide.elm-lang.org](http://guide.elm-lang.org/), particularly the sections on [The Elm Architecture](http://guide.elm-lang.org/architecture/index.html). This will help you get a feel for 0.17. diff --git a/docs/upgrade-instructions/0.18.md b/docs/upgrade-instructions/0.18.md deleted file mode 100644 index 8370ad8561..0000000000 --- a/docs/upgrade-instructions/0.18.md +++ /dev/null @@ -1,161 +0,0 @@ -# Upgrading to 0.18 - -Like always, not that much has really changed. To make the process as smooth as possible, this document outlines all the things you will want to do to use 0.18. - - - [Update `elm-package.json`](#update-elm-packagejson) - - [List Ranges](#list-ranges) - - [No More Primes](#no-more-primes) - - [Backticks and `andThen`](#backticks-and-andthen) - - [Renamed Functions in Core](#renamed-functions-in-core) - - [Package Changes](#package-changes) - -A lot of this can be done automatically with [`elm-upgrade`](https://github.com/avh4/elm-upgrade#elm-upgrade), so check it out after reading through this document! - - -## Update elm-package.json - -So the first thing you want to do is update your `elm-package.json` file. The only tricky thing is that the HTTP package moved: - - - `evancz/elm-http` => [`elm-lang/http`](http://package.elm-lang.org/packages/elm-lang/http/latest) - -From there, here is an `elm-package.json` that has been properly updated: - -```json -{ - "version": "1.0.0", - "summary": "let people do a cool thing in a fun way", - "repository": "https://github.com/user/project.git", - "license": "BSD3", - "source-directories": [ - "src" - ], - "exposed-modules": [], - "dependencies": { - "elm-lang/core": "5.0.0 <= v < 6.0.0", - "elm-lang/html": "2.0.0 <= v < 3.0.0", - "elm-lang/http": "1.0.0 <= v < 2.0.0", - "evancz/elm-markdown": "3.0.1 <= v < 4.0.0" - }, - "elm-version": "0.18.0 <= v < 0.19.0" -} -``` - -The only changes should be in the `dependencies` and `elm-version` fields where you need to update constraints. - -The easiest way to get this all set up is to use [`elm-upgrade`](https://github.com/avh4/elm-upgrade#elm-upgrade), but you can also: - - - Update `elm-version` by hand. - - Remove everything from `dependencies` by hand. - - Install what you need with `elm-package install elm-lang/core` one-by-one. - - -## List Ranges - -The `[1..5]` syntax has been removed. - -So replace any occurance of `[1..9]` with `List.range 1 9`. - - -## No More Primes - -You are not allowed to have primes in variable names, so things like `type'` are renamed to `type_`. - - -## Backticks and `andThen` - -Elm used to let you take normal functions and use them as infix operators. This is most notable in the case of `andThen` which is pretty much the only function that used this feature. You will want to make the following updates to your code: - -```elm --- old - -andThenIn17 : Result String Int -andThenIn17 = - String.toInt "1234" - `Result.andThen` \year -> isValidYear year - --- andThen : Result x a -> (a -> Result x b) -> Result x b - - --- new - -andThenIn18 : Result String Int -andThenIn18 = - String.toInt "1234" - |> Result.andThen (\year -> isValidYear year) - --- andThen : (a -> Result x b) -> Result x a -> Result x b -``` - -Notice that the backtick style is replaced by pipelining. The `onError` function has been flipped in the same way, so if you are working with tasks you may say something like this in 0.18: - -```elm -type Msg = NewText String | DidNotLoad - -tasksIn18 : Task x Msg -tasksIn18 = - Http.toTask (Http.getString "http://example.com/war-and-peace") - |> Task.andThen (\fullText -> Task.succeed (NewText fullText)) - |> Task.onError (\error -> Task.succeed DidNotLoad) -``` - -This also means that `andThen` and `onError` group together much better than in the infix style. - -**This change should be happening across the entire Elm ecosystem as package authors upgrade to 0.18.** - - -## Renamed Functions in Core - -A couple functions have been removed or renamed. - - - [`Json.Decode`](http://package.elm-lang.org/packages/elm-lang/core/5.0.0/Json-Decode) - - `objectN` becomes `mapN` (Note: `object1` becomes `map`) - - `tupleN` becomes `mapN` with `index` - - `(:=)` becomes `field` - - `andThen` args flip - - - [`Bitwise`](http://package.elm-lang.org/packages/elm-lang/core/5.0.0/Bitwise) - - `shiftLeft` becomes `shiftLeftBy` and args flip - - `shiftRight` becomes `shiftRightBy` and args flip - - `shiftRightLogical` becomes `shiftRightZfBy` and args flip - - - [`Task`](http://package.elm-lang.org/packages/elm-lang/core/5.0.0/Task) - - `andThen` args flip - - `onError` args flip - - Removed `perform : (x -> msg) -> (a -> msg) -> Task x a -> Cmd msg` - - Added `perform : (a -> msg) -> Task Never a -> Cmd msg` - - Added `attempt : (Result x a -> msg) -> Task x a -> Cmd msg` - - Removed `toMaybe` and `toResult` in favor of using `onError` directly - - - [`Result`](http://package.elm-lang.org/packages/elm-lang/core/5.0.0/Result) - - Renamed `formatError` to `mapError` to match names in `Task` - - `andThen` args flip - - - [`Maybe`](http://package.elm-lang.org/packages/elm-lang/core/5.0.0/Maybe) - - `andThen` args flip - - Removed `oneOf` - - - [`Random`](http://package.elm-lang.org/packages/elm-lang/core/5.0.0/Random) - - `andThen` args flip - - - [`Tuple`](http://package.elm-lang.org/packages/elm-lang/core/5.0.0/Tuple) - - `Basics.fst` becomes `Tuple.first` - - `Basics.snd` becomes `Tuple.second` - - -## Package Changes - -The following packages have changed a little bit: - - - [`elm-lang/html`](http://package.elm-lang.org/packages/elm-lang/html/latest) collapsed `Html.App` into `Html`. So you need to remove any `import Html.App` imports and refer to `Html.program` instead. - - - [`elm-lang/http`](http://package.elm-lang.org/packages/elm-lang/http/latest) was redone to be easier and have more features. It now supports tracking progress and rate-limiting HTTP requests. It should be pretty easy to upgrade to the new stuff, but if you have a complex `Task` that chains many requests, you will want to use the `Http.toTask` function to keep that code working the same. - - - [`elm-lang/navigation`](http://package.elm-lang.org/packages/elm-lang/navigation/latest) no longer has its own concept of a `Parser`. You just turn a `Navigation.Location` into a message and it is fed into your normal `update` function. This means `Navigation.program` is now much closer to `Html.program` so this should simplify things a bit. - - - [`evancz/url-parser`](http://package.elm-lang.org/packages/evancz/url-parser/latest) is pretty much the same, but works better and is friendlier. New things include: - - You can use `` to parse query parameters. - - Some bugs about parsing leading and trailing slashes are fixed. - - The parser backtracks, always finding a valid parse of the URL if one exists. - - You can use `parsePath` to parse a `Navigation.Location` directly. - -In all cases, the packages have become simpler and easier to use. The actual changes did not seem to be too serious as I upgraded `elm-lang.org` and `package.elm-lang.org` and all the examples I control. diff --git a/docs/upgrade-instructions/0.19.0.md b/docs/upgrade-instructions/0.19.0.md deleted file mode 100644 index 4c5d7d99b1..0000000000 --- a/docs/upgrade-instructions/0.19.0.md +++ /dev/null @@ -1,164 +0,0 @@ -# Upgrading to 0.19 - -To make the process as smooth as possible, this document outlines all the things you need to do to upgrade to 0.19. - -- [Command Line](#command-line) -- [`elm.json`](#elmjson) -- [Changes](#changes) -- [`--optimize`](#--optimize) -- [Compiler Performance](#compiler-performance) -- [Parse Errors](#parse-errors) -- [Stricter Record Update Syntax](#stricter-record-update-syntax) -- [Removed User-Defined Operators](#removed-user-defined-operators) - -> **Note:** You can try out [`elm-upgrade`](https://github.com/avh4/elm-upgrade#elm-upgrade--) which automates some of the 0.18 to 0.19 changes. It is also in an alpha stage, and Aaron has said it makes sense to talk things through [here](https://github.com/avh4/elm-upgrade/issues). - -
- - -## Command Line - -There is now just one `elm` binary at the command line. The terminal commands are now: - -```bash -# 0.19 # 0.18 -elm make # elm-make -elm repl # elm-repl -elm reactor # elm-reactor -elm install # elm-package install -elm publish # elm-package publish -elm bump # elm-package bump -elm diff # elm-package diff -``` - - -
- - -## `elm.json` - -`elm-package.json` becomes `elm.json` which is specialized for applications and packages. For example, it helps you lock your dependencies in applications and get broad dependency ranges in packages. - -See the full outlines here: - - - `elm.json` for [applications](https://github.com/elm/compiler/blob/master/docs/elm.json/application.md) - - `elm.json` for [packages](https://github.com/elm/compiler/blob/master/docs/elm.json/package.md) - -Both are quite similar to the `elm-package.json` format, and `elm-upgrade` can help you with this. - -
- - -## Changes - -#### Functions Changed - -- `String.toInt : String -> Maybe Int` (not `Result` anymore) -- `String.toFloat : String -> Maybe Float` (not `Result` anymore) -- `Basics.toString` becomes [`Debug.toString`](https://package.elm-lang.org/packages/elm/core/latest/Debug#toString), [`String.fromInt`](https://package.elm-lang.org/packages/elm/core/latest/String#fromInt), and [`String.fromFloat`](https://package.elm-lang.org/packages/elm/core/latest/String#fromFloat). -- `Basics.rem 451 10` becomes [`remainderBy 10 451`](https://package.elm-lang.org/packages/elm/core/latest/Basics#remainderBy) -- `451 % 10` becomes [`modBy 10 451`](https://package.elm-lang.org/packages/elm/core/latest/Basics#modBy) -- `(,)` becomes [`Tuple.pair`](https://package.elm-lang.org/packages/elm/core/latest/Tuple#pair) -- `style : List (String, String) -> Attribute msg` becomes `String -> String -> Attribute msg` -- `Html.beginnerProgram` becomes [`Browser.sandbox`](https://package.elm-lang.org/packages/elm/browser/latest/Browser#sandbox). -- `Html.program` becomes [`Browser.element`](https://package.elm-lang.org/packages/elm/browser/latest/Browser#element) and [`Browser.document`](https://package.elm-lang.org/packages/elm/browser/latest/Browser#document). - - -#### Modules Moved - -- `Json.Encode` and `Json.Decode` moved to [`elm/json`](https://package.elm-lang.org/packages/elm/json/latest) -- `Time` and `Date` moved to [`elm/time`](https://package.elm-lang.org/packages/elm/time/latest/) with a significantly improved API -- `Random` moved to [`elm/random`](https://package.elm-lang.org/packages/elm/random/latest/) with a better implementation and a few new functions -- `Regex` moved to [`elm/regex`](https://package.elm-lang.org/packages/elm/regex/latest) with a much clearer README - - -#### Packages Moved - -- `elm-lang/*` moved to `elm/*` -- `evancz/url-parser` moved to [`elm/url`](https://package.elm-lang.org/packages/elm/url/latest) with a simpler and more flexible API -- `elm-tools/elm-parser` moved to [`elm/parser`](https://package.elm-lang.org/packages/elm/parser/latest) with speed boost when compiling with the `--optimize` flag -- [`elm/browser`](https://package.elm-lang.org/packages/elm/browser/latest) combines and simplifies the following 0.18 packages: - - `elm-lang/navigation` with smoother APIs - - `elm-lang/dom` with ability to get node positions and dimensions. - - `elm-lang/mouse` with decoders - - `elm-lang/window` - - `elm-lang/keyboard` uses decoders like [this](https://github.com/elm/browser/blob/master/notes/keyboard.md) - - `elm-lang/page-visibility` - - `elm-lang/animation-frame` - - -#### Functions Removed - -- `uncurry` -- `curry` -- `flip` -- `(!)` - -Prefer named helper functions in these cases. - -
- -## `--optimize` - -You can now compile with `elm make --optimize` which enables things like: - -- Reliable field name shortening in compiled assets -- Unbox things like `type Height = Height Float` to just be a float at runtime -- Unbox `Char` values -- Use more compact names for `type` constructors in compiled assets. - -Some of these optimizations require "forgetting information" that is useful while debugging, so the `Debug` module becomes unavailable when you add the `--optimize` flag. The idea being that you want to be shipping code with this flag (like `-O2` in C) but not compiling with it all day in development. - -
- - -## Compiler Performance - -I did a bunch of performance optimizations for the compiler itself. For example: - -- I rewrote the parser to be very significantly faster (partly by allocating very little!) -- I revamped how type inference looks up the type of foreign variables to be `O(1)` rather than `O(log(n))` -- I redid how code is generated to allow DCE with declarations as the level of granuality -- Packages are downloaded once per user and saved in `~/.elm/` -- Packages are built once for any given set of dependencies, so they do not contribute to build times of fresh projects. - -Point is, the compiler is very significantly faster! - - -
- - -## Parse Errors - -Part of rewriting the parser was making nicer parse errors. Many people only really see them when getting started, and rather than saying "man, these are terrible" they think "man, programming is hard" leading to a big underreporting of quality issues here. Anyway, please explore that a bit and see if you run into anything odd! - -
- - -## Stricter Record Update Syntax - -It used to be possible for `{ r | x = v }` to change the type of field `x`. This is no longer possible. This greatly improves the quality of error messages in many cases. - -You can still change the type of a field, but you must reconstruct the record with the record literal syntax, or with a record constructor. - -The idea is that 99.9% of uses get a much better experience with type errors, whereas 0.1% of uses become somewhat more verbose. As someone who had a bit of code that changed record types, I have found this to be a really excellent trade. - -
- - -## Removed User-Defined Operators - -It is no longer possible to define custom operators. For example, someone defined: - -```elm -(|-~->) : (a -> a1_1 -> a3) -> (a2 -> a1_1) -> a -> a2 -> a3 -``` - -They are still able to define that function, but it will need a human readable name that explains what it is meant to do. The reasoning behind this decision is outlined in detail in [this document](https://gist.github.com/evancz/769bba8abb9ddc3bf81d69fa80cc76b1). - -
- - -## Notes: - -- `toString` — A relatively common bug was to show an `Int` in the UI, and then later that value changes to something else. `toString` would just show wrong information until someone noticed. The new `String.fromInt` and `String.fromFloat` ensure that cannot happen. Furthermore, more elaborate types almost certainly need localization or internationalization, which should be handled differently anyway. diff --git a/docs/upgrade-instructions/0.19.1.md b/docs/upgrade-instructions/0.19.1.md deleted file mode 100644 index b0a0fe21e8..0000000000 --- a/docs/upgrade-instructions/0.19.1.md +++ /dev/null @@ -1,60 +0,0 @@ -# Upgrading to 0.19.1 - -**There are no language changes**, so once you swap to `"elm-version": "0.19.1"` in your `elm.json`, most users should be able to proceed without any further code changes. **You may run into a handful of bugfixes though!** These cases are outlined below! - - -
- -## Improvements - -- Parse error message quality (like [this](https://github.com/elm/error-message-catalog/issues/255) and [this](https://github.com/elm/error-message-catalog/issues/225)) -- Faster compilation, especially for incremental compiles -- Uses filelocks so that cached files are not corrupted when plugins run `elm make` multiple times on the same project at the same time. (Still worth avoiding that though!) -- More intuitive multiline declarations in REPL -- Various bug fixes (e.g. `--debug`, `x /= 0`, `type Height = Height Float` in `--optimize`) - - -
- -## Detectable Bug Fixes - -There are three known cases where code that compiled with 0.19.0 will not compile with 0.19.1 due to bug fixes: - - -### 1. Ambiguous Imports - -Say you have an import like this: - -```elm -import Html exposing (min) -import Regex exposing (never) - -x = min -y = never -``` - -These should be reported as ambiguous usages since the names are also exposed by `Basics`, but there was a regression in 0.19.0 described [here](https://github.com/elm/compiler/issues/1945) such that they weren't caught in specific circumstances. - -The fix is to use a qualified name like `Html.min` or `Regex.never` to make it unambiguous. - -We found a couple instances of this in packages and have submitted PRs to the relevant authors in August 2019. You may run into this in your own code as well. - -For more details on why this is considered a regression, check out the details [here](https://github.com/elm/compiler/issues/1945#issuecomment-507871919) or try it in 0.18.0 to see how it worked before. - - -### 2. Tabs in Comments - -The 0.19.0 binaries did not catch tab characters in comments. The new parser is better at checking for tabs, so it will object when it finds these. - -Again, we found this in some packages and reached out to the relevant authors with PRs so patches would be published before the 0.19.1 release. - - -### 3. Port Module with no Ports - -If you have any files that start with: - -```elm -port module Main exposing (..) -``` - -But they do not actually have any `port` declarations, the 0.19.1 binary will ask you to switch to a normal module declaration like `module Main exposing (..)` diff --git a/docs/upgrade-instructions/earlier.md b/docs/upgrade-instructions/earlier.md deleted file mode 100644 index 07e1e4eb29..0000000000 --- a/docs/upgrade-instructions/earlier.md +++ /dev/null @@ -1,446 +0,0 @@ - -# 0.16 - -Read all about it at these links: - - * http://elm-lang.org/blog/compilers-as-assistants - * https://github.com/elm-lang/elm-platform/blob/master/upgrade-docs/0.16.md - - -# 0.15 - -### Improve Import Syntax - -The changes in 0.14 meant that people were seeing pretty long import sections, -sometimes with two lines for a single module to bring it in qualified and to -expose some unqualified values. The new syntax is like this: - -```elm -import List - -- Just bring `List` into scope, allowing you to say `List.map`, - -- `List.filter`, etc. - -import List exposing (map, filter) - -- Bring `List` into scope, but also bring in `map` and `filter` - -- without any prefix. - -import List exposing (..) - -- Bring `List` into scope, and bring in all the values in the - -- module without a prefix. - -import List as L - -- Bring `L` into scope, but not `List`. This lets you say `L.map`, - -- `L.filter`, etc. - -import List as L exposing (map, filter) - -- Bring `L` into scope along with unqualified versions of `map` - -- and `filter`. - -import List as L exposing (..) - -- Bring in all the values unqualified and qualified with `L`. -``` - -This means you are doing more with each import, writing less overall. It also -makes the default imports more comprehensive because you now can refer to -`List` and `Result` without importing them explicitly as they are in the -defaults. - -### Revise Port Syntax - -One common confusion with the `port` syntax is that the only difference -between incoming ports and outgoing ports is whether the type annotation comes -with a definition. To make things a bit clearer, we are using the keywords -`foreign input` and `foreign output`. - -```elm -foreign input dbResults : Stream String - -foreign output dbRequests : Stream String -foreign output dbRequests = - Stream.map toRequest userNames -``` - -### Input / Output - -The biggest change in 0.15 is the addition of tasks, allowing us to represent -arbitrary effects in Elm in a safe way. This parallels how ports work, so we -are trying to draw attention to that in syntax. First addition is a way to -create new inputs to an Elm program. - -```elm -input actions : Input Action -``` - -This creates a `Input` that is made up of an `Address` you can send messages to -and a `Stream` of those messages. This is similar to a `foreign input` except -there we use the name as the address. The second addition is a way to run -tasks. - -```elm -output Stream.map toRequest userNames -``` - -This lets us turn tasks into effects in the world. Sometimes it is useful to -pipe the results of these tasks back into Elm. For that, we have the third and -final addition. - -```elm -input results : Stream (Result Http.Error String) -input results from - Stream.map toRequest userNames -``` - -# 0.14.1 - -Modify default import of `List` to expose `(::)` as well. - - -# 0.14 - -### Breaking Changes - - * Keyword `data` renamed to `type` - * Keyword `type` renamed to `type alias` - - -# 0.13 - -### Improvements: - - * Type aliases in port types - * Add Keyboard.alt and Keyboard.meta - * Add Debug.crash, Debug.watch, Debug.watchSummary, and Debug.trace - * Add List.indexedMap and List.filterMap - * Add Maybe.map - * Add Basics.negate - * Add (>>) to Basics as in F# - * Add --bundle-runtime flag which creates stand-alone Elm programs - * Error on ambiguious use of imported variables - * Replace dependency on Pandoc with cheapskate+kate - * Better architecture for compiler. Uses types to make compilation pipeline - safer, setting things up for giving programmatic access to the AST to - improve editor and IDE support. - -### Breaking Changes: - - * Rename (.) to (<<) as in F# - * Rename Basics.id to Basics.identity - * Rename Basics.div to (//) - * Rename Basics.mod to (%) - * Remove Maybe.justs for (List.filterMap identity) - * Remove List.and for (List.foldl (&&) True) - * Remove List.or for (List.foldl (||) False) - * Unambiguous syntax for importing ADTs and type aliases - * sqrt and logBase both only work on Floats now - -# 0.12.3 - - * Minor changes to support webgl as a separate library - * Switch from HSV to HSL - * Programmatic access to colors with toHsl and toRgb - -# 0.12.1 - -### Improvements: - - * New Array library (thanks entirely to @Xashili) - * Json.Value can flow through ports - * Improve speed and stack usage in List library (thanks to @maxsnew) - * Add Dict.filter and Dict.partition (thanks to @hdgarrood) - -### Breaking Changes: - - * Revamp Json library, simpler with better names - * Revamp JavaScript.Experimental library to have slightly better names - * Remove JavaScript library which was made redundant by ports - -# 0.12 - -### Breaking Changes: - - * Overhaul Graphics.Input library (inspired by Spiros Eliopoulos and Jeff Smitts) - * Overhaul Text library to accomodate new Graphics.Input.Field - library and make the API more consistent overall - * Overhaul Regex library (inspired by Attila Gazso) - * Change syntax for "import open List" to "import List (..)" - * Improved JSON format for types generated by elm-doc - * Remove problematic Mouse.isClicked signal - * Revise the semantics of keepWhen and dropWhen to only update when - the filtered signal changes (thanks Max New and Janis Voigtländer) - -### Improvements: - - * Add Graphics.Input.Field for customizable text fields - * Add Trampoline library (thanks to @maxsnew and @timthelion) - * Add Debug library (inspired by @timthelion) - * Drastically improved performance on markdown parsing (thanks to @Dandandan) - * Add Date.fromTime function - * Use pointer-events to detect hovers on layered elements (thanks to @Xashili) - * Fix bugs in Bitwise library - * Fix bug when exporting Maybe values through ports - -# 0.11 - - * Ports, a new FFI that is more general and much nicer to use - * Basic compiler tests (thanks to Max New) - -# 0.10.1 - - * sort, sortBy, sortWith (thanks to Max Goldstein) - * elm-repl - * Bitwise library - * Regex library - * Improve Transform2D library (thanks to Michael Søndergaard) - -# 0.10 - - * Native strings - * Tango colors - * custom precedence and associativity for infix operators - * elm-doc released with new documentation format - * Realiasing in type errors - * Rename Matrix2D => Transform2D - * Add Random.floatList (thank you Max GoldStein) - * Fix remove function in Dict (thank you Max New) - * Start using language-ecmascript for JS generation - * Make compatable with cabal-1.18 (thank you Justin Leitgeb) - * All functions with 10+ arguments (thanks to Max New) - -# 0.9.1 - - * Allow custom precedence and associativity for user-defined infix ops - * Realias types before printing - * Switch to Tango color scheme, adding a bunch of nice colors - * add the greyscale function for easily producing greys - * Check the type of main - * Fix miscellaneous bugs in type checker - * Switch name of Matrix2D to Transform2D - -# 0.9 - -Build Improvements: - * Major speed improvements to type-checker - * Type-checker should catch _all_ type errors now - * Module-level compilation, only re-compile if necessary - * Import types and type aliases between modules - * Intermediate files are generated to avoid unneeded recompilation - and shorten compile time. These files go in ElmFiles/ by default - * Generated files are placed in ElmFiles/ by default, replicating - the directory structure of your source code. - -Error Messages: - * Cross-module type errors - * Errors for undefined values - * Pretty printing of expressions and types - -Syntax: - * Pattern matching on literals - * Pattern aliases with `as` (Andrew) - * Unary negation - * Triple-quoted multi-line strings - * Type annotations in let expressions (Andrew) - * Record Constructors - * Record type aliases can be closed on the zeroth column - * (,,) syntax in types - * Allow infix op definitions without args: (*) = add - * Unparenthesized if, let, case, lambda at end of binary expressions - -elm-server: - * Build multi-module projects - * Report all errors in browser - -Libraries: - * Detect hovering over any Element - * Set alpha of arbitrary forms in collages - * Switch Text.height to use px instead of em - -Bug Fixes: - * Many bug fixes for collage, especially when rendering Elements. - -Website: - * Hot-swapping - * Much faster page load with pre-compiled Elm files (Max New) - - - - -forgot to fill this in again... - - -# 0.7.2 - -* Add a WebSockets library. -* Add support for the mathematical looking operator for function composition (U+2218). - - -forgot to fill this in for a while... - - -# 0.5.0 - -* Add Dict, Set, and Automaton libraries! - -* Add (,,) notation for creating tuples. - -* Redo HTTP library, allowing any kind of request and more flexibility. - -* Remove the library prefixes `Data.`, `Graphics.`, and `Signal.` because - they were more confusing than helpful. - -* Better type error reporting for ambiguous uses of variables and for - variables in aliased modules. - -* Add `readInt` and `readFloat` functions. -* Add `complement` function to compute complementary colors. -* Ensure that `String` is treated as an alias of `[Char]`. - -* Fix bug in pattern parsing. `A B _ _` was parsed as `A (B _ _)`. -* Make pattern matching a bit more compact in generated code. -* Make generated JS more readable. - -* The Haskell API exports the absolute path to the Elm runtime - system (with the corresponding version number). This makes it easier - to run Elm programs with less setup. - - - -# 0.4.0 - -This version is all about graphics: nicer API with more features and major -efficiency improvements. I am really excited about this release! - -* Add native Markdown support. You can now embed markdown directly in .elm files - and it is used as an `Element`. Syntax is `[markdown| ... |]` where `...` is - formatted as described [here](http://daringfireball.net/projects/markdown/). - Content can span multiple lines too. - -* Drastically improve the `collage` interface. You can now move, rotate, and scale - the following forms: - - Elements (any Element you want can be turned into a Form with `toForm`) - - Images - - Shapes (shapes can be textured now too) - - Lines - This will make it way easier to make games in Elm. Games can now include text, - gifs, videos, and any other Element you can think of. - -* Add `--minify` flag, to minify JS code. - -* Significantly improve performance of pattern matching. - -* Compiler performs beta-reduction in some simple cases. - -* The rendering section of the Elm runtume-system (RTS) has been totally rewritten, - making screen refreshes use fewer cycles, less memory, and cause less garbage-collection. - - - -# 0.3.6 - -* Add JSON library. - -* Type-error messages improved. Gives better context for error, making them - easier to find. Better messages for runtime errors as well (errors that - the type checker cannot find yet). - -* Add Comparable super-type which allows the comparision of any values - of type {Int,Float,Char,String}. Now possible to make Set and Map libraries. - -* Parser now handles decimal numbers. - -* Added many new functions for manipulating numbers: - - truncate, round, floor, ceiling :: Float -> Int - - toFloat :: Int -> Float - - (^) :: Number -> Number -> Number - - e :: Float - -* Foreign import/export statements no longer have to preceed all other - variable and datatype definitions. They can be mixed in, making things - a bit more readable/natural. - -* Bug fixes: - - The `toText` function did not escape strings properly - - Correct `castJSTupleToTupleN` family of functions - - `foldr1` took the leftmost element as the base case instead of the rightmost - - Fix minor display issue in latest version of Chrome. - - Fix behavior of [ lo .. hi ] syntax (now [4..0] == [], not [0]). - - - -# 0.3.5 - -* Add JavaScript event interface. Allows Elm to import and export JS values - and events. This makes it possible to import and export Elements, so users - can use JS techniques and libraries if necessary. Conversion between JS - and Elm values happens with functions from here: - http://localhost:8000/docs/Foreign/JavaScript.elm - http://localhost:8000/docs/Foreign/JavaScript/Experimental.elm - -* Add new flags to help with JavaScript event interface. - -* Add three built-in event listeners (elm_title, elm_log, elm_redirect) that - make it possible to make some common/simple imperative actions without - having to worry about writing the JS yourself. For example: - foreign export jsevent "elm_title" - title :: Signal JSString - will update the page's title to the current value of the title signal. - Empty strings are ignored. "elm_redirect" and "elm_log" events work much - the same way, except that "elm_log" does not skip empty strings. - -* Add new Signal functions: - count :: Signal a -> Signal Int - keepIf :: (a -> Bool) -> a -> Signal a -> Signal a - dropIf :: (a -> Bool) -> a -> Signal a -> Signal a - keepWhen :: Signal Bool -> a -> Signal a -> Signal a - dropWhen :: Signal Bool -> a -> Signal a -> Signal a - dropRepeats :: Signal a -> Signal a - sampleOn :: Signal a -> Signal b -> Signal b - clicks :: Signal () - The keep and drop functions make it possible to filter events, which - was not possible in prior releases. More documentation: - http://elm-lang.org/docs/Signal/Signal.elm - -* Add examples of JS event interface and new signal functions: - https://github.com/evancz/Elm/tree/master/Examples/elm-js - -* Use more compressed format for strings. Should make strings 10-12 times - more space efficient than in previous releases. Anecdotal evidence: - Elm's home page is now 70% of its previous size. - -* Add new function to Data.List: - last :: [a] -> a - -* Fix parenthesization bug with binary operators. - - - -# 0.3.0 - -### Major Changes (Read this part!) - -* Add a basic module system. -* Elm's JavaScript runtime is now distributed with the elm package. - Previously it was available for download as an unversioned JavaScript - file (elm-mini.js). It is now installed with the elm compiler as - elm-runtime-0.3.0.js. Be sure to serve the Elm runtime system that matches - the version of the compiler used to generate JavaScript. When working - locally, the compiler will automatically use your local copy of this file. -* BREAKING CHANGE: rgb and rgba (in the color module) now take their red, - green, and blue components as integers between 0 and 255 inclusive. -* Improve error messages for parse errors and runtime errors. - - -### New Functions and Other Additions - -* Add support for keyboard events: Keyboard.Raw -* Add buttons in Signal.Input: - button :: String -> (Element, Signal Bool) -* Add new basic element (an empty rectangle, good for adding spaces): - rectangle :: Int -> Int -> Element -* Add (an awkwardly named) way to display right justified text: rightedText -* Add two basic libraries: Data.Char and Data.Maybe -* Add some new colors: magenta, yellow, cyan, gray, grey -* Add functions to Data.List module: take, drop -* Add functions to Prelude (the default imports): - fst, snd, curry, uncurry, and a bunch of list functions -* Add --make, --separate-js, and --only-js flags to help compile - with the new module system. diff --git a/elm.cabal b/elm.cabal deleted file mode 100644 index bf1cfcf01e..0000000000 --- a/elm.cabal +++ /dev/null @@ -1,238 +0,0 @@ - -Name: elm -Version: 0.19.1 - -Synopsis: - The `elm` command line interface. - -Description: - This includes commands like `elm make`, `elm repl`, and many others - for helping make Elm developers happy and productive. - -Homepage: https://elm-lang.org - -License: BSD3 -License-file: LICENSE - -Author: Evan Czaplicki -Maintainer: info@elm-lang.org -Copyright: Copyright (c) 2011-present, Evan Czaplicki - -Category: Compiler, Language - -Cabal-version: >=1.9 -Build-type: Simple - -source-repository head - type: git - location: git://github.com/elm/compiler.git - - -Flag dev { - Description: Turn off optimization and make warnings errors - Default: False -} - - -Executable elm - if flag(dev) - ghc-options: -O0 -Wall -Werror - else - ghc-options: -O2 -rtsopts -threaded "-with-rtsopts=-N -qg -A128m" - -- add -eventlog for (elm make src/Main.elm +RTS -l; threadscope elm.eventlog) - -- https://www.oreilly.com/library/view/parallel-and-concurrent/9781449335939/ - - Hs-Source-Dirs: - compiler/src - builder/src - terminal/impl - terminal/src - - other-extensions: - TemplateHaskell - - Main-Is: - Main.hs - - other-modules: - Bump - Develop - Diff - Init - Install - Make - Publish - Repl - - -- terminal args - Terminal - Terminal.Chomp - Terminal.Error - Terminal.Helpers - Terminal.Internal - - -- from terminal/ - Develop.Generate.Help - Develop.Generate.Index - Develop.StaticFiles - Develop.StaticFiles.Build - - -- from builder/ - Build - BackgroundWriter - Deps.Bump - Deps.Diff - Deps.Registry - Deps.Solver - Deps.Website - File - Generate - Http - Reporting - Reporting.Exit - Reporting.Exit.Help - Reporting.Task - Stuff - - -- Elm things - Elm.Outline - Elm.Details - -- - Elm.Compiler.Imports - Elm.Compiler.Type - Elm.Compiler.Type.Extract - Elm.Constraint - Elm.Docs - Elm.Float - Elm.Interface - Elm.Kernel - Elm.Licenses - Elm.Magnitude - Elm.ModuleName - Elm.Package - Elm.String - Elm.Version - - -- data structures - Data.Bag - Data.Index - Data.Map.Utils - Data.Name - Data.NonEmptyList - Data.OneOrMore - Data.Utf8 - - -- json - Json.Decode - Json.Encode - Json.String - - -- from compiler/ - AST.Canonical - AST.Optimized - AST.Source - AST.Utils.Binop - AST.Utils.Shader - AST.Utils.Type - Canonicalize.Effects - Canonicalize.Environment - Canonicalize.Environment.Dups - Canonicalize.Environment.Foreign - Canonicalize.Environment.Local - Canonicalize.Expression - Canonicalize.Module - Canonicalize.Pattern - Canonicalize.Type - Compile - Generate.Html - Generate.JavaScript - Generate.JavaScript.Builder - Generate.JavaScript.Expression - Generate.JavaScript.Functions - Generate.JavaScript.Name - Generate.Mode - Nitpick.Debug - Nitpick.PatternMatches - Optimize.Case - Optimize.DecisionTree - Optimize.Expression - Optimize.Module - Optimize.Names - Optimize.Port - Parse.Declaration - Parse.Expression - Parse.Keyword - Parse.Module - Parse.Number - Parse.Pattern - Parse.Shader - Parse.Space - Parse.String - Parse.Symbol - Parse.Type - Parse.Variable - Parse.Primitives - Reporting.Annotation - Reporting.Doc - Reporting.Error - Reporting.Error.Canonicalize - Reporting.Error.Docs - Reporting.Error.Import - Reporting.Error.Json - Reporting.Error.Main - Reporting.Error.Pattern - Reporting.Error.Syntax - Reporting.Error.Type - Reporting.Render.Code - Reporting.Render.Type - Reporting.Render.Type.Localizer - Reporting.Report - Reporting.Result - Reporting.Suggest - Reporting.Warning - Type.Constrain.Expression - Type.Constrain.Module - Type.Constrain.Pattern - Type.Error - Type.Instantiate - Type.Occurs - Type.Solve - Type.Type - Type.Unify - Type.UnionFind - Paths_elm - - Build-depends: - ansi-terminal >= 0.8 && < 0.9, - ansi-wl-pprint >= 0.6.8 && < 0.7, - base >=4.11 && <5, - binary >= 0.8 && < 0.9, - bytestring >= 0.9 && < 0.11, - containers >= 0.5.8.2 && < 0.6, - directory >= 1.2.3.0 && < 2.0, - edit-distance >= 0.2 && < 0.3, - file-embed, - filelock, - filepath >= 1 && < 2.0, - ghc-prim >= 0.5.2, - haskeline, - HTTP >= 4000.2.5 && < 4000.4, - http-client >= 0.6 && < 0.7, - http-client-tls >= 0.3 && < 0.4, - http-types >= 0.12 && < 1.0, - language-glsl >= 0.3, - mtl >= 2.2.1 && < 3, - network >= 2.4 && < 2.7, - parsec, - process, - raw-strings-qq, - scientific, - SHA, - snap-core, - snap-server, - template-haskell, - time >= 1.9.1, - unordered-containers, - utf8-string, - vector, - zip-archive diff --git a/elm.json b/elm.json new file mode 100644 index 0000000000..d8320af0eb --- /dev/null +++ b/elm.json @@ -0,0 +1,50 @@ +{ + "type": "application", + "source-directories": [ + "src" + ], + "elm-version": "0.19.1", + "dependencies": { + "direct": { + "Janiczek/elm-vlq": "1.0.0", + "dasch/levenshtein": "1.0.3", + "elm/bytes": "1.0.8", + "elm/core": "1.0.5", + "elm/http": "2.0.0", + "elm/json": "1.1.3", + "elm/regex": "1.0.0", + "elm/time": "1.0.0", + "elm/url": "1.0.0", + "elm-community/array-extra": "2.6.0", + "elm-community/basics-extra": "4.1.0", + "elm-community/list-extra": "8.7.0", + "elm-community/maybe-extra": "5.3.0", + "elm-community/result-extra": "2.4.0", + "guida-lang/glsl": "1.0.0", + "guida-lang/graph": "1.0.1", + "jxxcarlson/hex": "4.0.1", + "obiloud/numeric-decimal": "3.0.1", + "rtfeldman/elm-hex": "1.0.0", + "the-sett/elm-pretty-printer": "3.1.0", + "truqu/elm-base64": "2.0.4" + }, + "indirect": { + "andre-dietrich/parser-combinators": "4.1.0", + "elm/file": "1.0.5", + "elm/parser": "1.1.0", + "fredcy/elm-parseint": "2.0.1", + "pilatch/flip": "1.0.0", + "zwilias/elm-rosetree": "1.5.0" + } + }, + "test-dependencies": { + "direct": { + "elm-explorations/test": "2.2.0" + }, + "indirect": { + "elm/html": "1.0.0", + "elm/random": "1.0.0", + "elm/virtual-dom": "1.0.4" + } + } +} diff --git a/eslint.config.mjs b/eslint.config.mjs new file mode 100644 index 0000000000..79f74a11d7 --- /dev/null +++ b/eslint.config.mjs @@ -0,0 +1,51 @@ +import { defineConfig, globalIgnores } from "eslint/config"; +import globals from "globals"; +import js from "@eslint/js"; +import pluginJest from "eslint-plugin-jest"; + + +export default defineConfig([ + globalIgnores([ + "bin/guida.js", + "bin/guida.min.js", + "lib/guida.browser.js", + "lib/guida.browser.min.js", + "lib/guida.node.js", + "lib/guida.node.min.js", + "elm-stuff", + "guida-stuff", + ]), + { files: ["**/*.{js,mjs,cjs}"] }, + { files: ["**/*.js"], languageOptions: { sourceType: "commonjs" } }, + { files: ["bin/**/*.{js,mjs,cjs}"], languageOptions: { globals: globals.node } }, + { files: ["lib/browser.js"], languageOptions: { globals: globals.browser } }, + { files: ["lib/node.js"], languageOptions: { globals: globals.node } }, + { files: ["try/**/*.{js,mjs,cjs}"], languageOptions: { globals: { ...globals.browser, ...globals.node } } }, + { files: ["scripts/*.js"], languageOptions: { globals: globals.node } }, + { + files: ["**/*.{js,mjs,cjs}"], + plugins: { js }, + extends: ["js/recommended"], + rules: { + "no-unused-vars": ["error", { + "argsIgnorePattern": "^_", + "caughtErrorsIgnorePattern": "^_" + }] + } + }, + { + files: ["**/*.test.js"], + plugins: { jest: pluginJest }, + languageOptions: { + globals: { ...globals.node, ...pluginJest.environments.globals.globals }, + }, + rules: { + "no-empty": ["error", { "allowEmptyCatch": true }], + "jest/no-disabled-tests": "warn", + "jest/no-focused-tests": "error", + "jest/no-identical-title": "error", + "jest/prefer-to-have-length": "warn", + "jest/valid-expect": "error", + }, + }, +]); \ No newline at end of file diff --git a/worker/outlines/compile/elm.json b/examples/elm.json similarity index 73% rename from worker/outlines/compile/elm.json rename to examples/elm.json index fb7242f7c9..1f59dad67e 100644 --- a/worker/outlines/compile/elm.json +++ b/examples/elm.json @@ -1,13 +1,13 @@ { "type": "application", "source-directories": [ - "../../src" + "src" ], "elm-version": "0.19.1", "dependencies": { "direct": { - "elm/browser": "1.0.1", - "elm/core": "1.0.2", + "elm/browser": "1.0.2", + "elm/core": "1.0.5", "elm/file": "1.0.5", "elm/html": "1.0.0", "elm/http": "2.0.0", @@ -16,13 +16,13 @@ "elm/svg": "1.0.1", "elm/time": "1.0.0", "elm-explorations/linear-algebra": "1.0.3", - "elm-explorations/webgl": "1.1.0", - "evancz/elm-playground": "1.0.2" + "elm-explorations/webgl": "1.1.3", + "evancz/elm-playground": "1.0.3" }, "indirect": { "elm/bytes": "1.0.8", "elm/url": "1.0.0", - "elm/virtual-dom": "1.0.2" + "elm/virtual-dom": "1.0.3" } }, "test-dependencies": { diff --git a/examples/src/Animation.elm b/examples/src/Animation.elm new file mode 100644 index 0000000000..24f398e575 --- /dev/null +++ b/examples/src/Animation.elm @@ -0,0 +1,27 @@ +module Animation exposing (main) + +-- Create animations that spin, wave, and zig-zag. +-- This one is a little red wagon bumping along a dirt road. +-- +-- Learn more about the playground here: +-- https://package.elm-lang.org/packages/evancz/elm-playground/latest/ +-- + +import Playground exposing (..) + + +main = + animation view + + +view time = + [ octagon darkGray 36 + |> moveLeft 100 + |> rotate (spin 3 time) + , octagon darkGray 36 + |> moveRight 100 + |> rotate (spin 3 time) + , rectangle red 300 80 + |> moveUp (wave 50 54 2 time) + |> rotate (zigzag -2 2 8 time) + ] diff --git a/examples/src/Book.elm b/examples/src/Book.elm new file mode 100644 index 0000000000..bdd67198a7 --- /dev/null +++ b/examples/src/Book.elm @@ -0,0 +1,90 @@ +module Book exposing (main) + +-- Make a GET request to load a book called "Public Opinion" +-- +-- Read how it works: +-- https://guide.elm-lang.org/effects/http.html +-- + +import Browser +import Html exposing (Html, pre, text) +import Http + + + +-- MAIN + + +main = + Browser.element + { init = init + , update = update + , subscriptions = subscriptions + , view = view + } + + + +-- MODEL + + +type Model + = Failure + | Loading + | Success String + + +init : () -> ( Model, Cmd Msg ) +init _ = + ( Loading + , Http.get + { url = "https://elm-lang.org/assets/public-opinion.txt" + , expect = Http.expectString GotText + } + ) + + + +-- UPDATE + + +type Msg + = GotText (Result Http.Error String) + + +update : Msg -> Model -> ( Model, Cmd Msg ) +update msg model = + case msg of + GotText result -> + case result of + Ok fullText -> + ( Success fullText, Cmd.none ) + + Err _ -> + ( Failure, Cmd.none ) + + + +-- SUBSCRIPTIONS + + +subscriptions : Model -> Sub Msg +subscriptions model = + Sub.none + + + +-- VIEW + + +view : Model -> Html Msg +view model = + case model of + Failure -> + text "I was unable to load your book." + + Loading -> + text "Loading..." + + Success fullText -> + pre [] [ text fullText ] diff --git a/examples/src/Buttons.elm b/examples/src/Buttons.elm new file mode 100644 index 0000000000..9f450686ed --- /dev/null +++ b/examples/src/Buttons.elm @@ -0,0 +1,64 @@ +module Buttons exposing (main) + +-- Press buttons to increment and decrement a counter. +-- +-- Read how it works: +-- https://guide.elm-lang.org/architecture/buttons.html +-- + +import Browser +import Html exposing (Html, button, div, text) +import Html.Events exposing (onClick) + + + +-- MAIN + + +main = + Browser.sandbox { init = init, update = update, view = view } + + + +-- MODEL + + +type alias Model = + Int + + +init : Model +init = + 0 + + + +-- UPDATE + + +type Msg + = Increment + | Decrement + + +update : Msg -> Model -> Model +update msg model = + case msg of + Increment -> + model + 1 + + Decrement -> + model - 1 + + + +-- VIEW + + +view : Model -> Html Msg +view model = + div [] + [ button [ onClick Decrement ] [ text "-" ] + , div [] [ text (String.fromInt model) ] + , button [ onClick Increment ] [ text "+" ] + ] diff --git a/examples/src/Cards.elm b/examples/src/Cards.elm new file mode 100644 index 0000000000..32fd2e6835 --- /dev/null +++ b/examples/src/Cards.elm @@ -0,0 +1,163 @@ +module Cards exposing (main) + +-- Press a button to draw a random card. +-- +-- Dependencies: +-- elm install elm/random +-- + +import Browser +import Html exposing (..) +import Html.Attributes exposing (style) +import Html.Events exposing (..) +import Random + + + +-- MAIN + + +main = + Browser.element + { init = init + , update = update + , subscriptions = subscriptions + , view = view + } + + + +-- MODEL + + +type alias Model = + { card : Card + } + + +init : () -> ( Model, Cmd Msg ) +init _ = + ( Model Three + , Cmd.none + ) + + +type Card + = Ace + | Two + | Three + | Four + | Five + | Six + | Seven + | Eight + | Nine + | Ten + | Jack + | Queen + | King + + + +-- UPDATE + + +type Msg + = Draw + | NewCard Card + + +update : Msg -> Model -> ( Model, Cmd Msg ) +update msg model = + case msg of + Draw -> + ( model + , Random.generate NewCard cardGenerator + ) + + NewCard newCard -> + ( Model newCard + , Cmd.none + ) + + +cardGenerator : Random.Generator Card +cardGenerator = + Random.uniform Ace + [ Two + , Three + , Four + , Five + , Six + , Seven + , Eight + , Nine + , Ten + , Jack + , Queen + , King + ] + + + +-- SUBSCRIPTIONS + + +subscriptions : Model -> Sub Msg +subscriptions model = + Sub.none + + + +-- VIEW + + +view : Model -> Html Msg +view model = + div [] + [ button [ onClick Draw ] [ text "Draw" ] + , div [ style "font-size" "12em" ] [ text (viewCard model.card) ] + ] + + +viewCard : Card -> String +viewCard card = + case card of + Ace -> + "🂡" + + Two -> + "🂢" + + Three -> + "🂣" + + Four -> + "🂤" + + Five -> + "🂥" + + Six -> + "🂦" + + Seven -> + "🂧" + + Eight -> + "🂨" + + Nine -> + "🂩" + + Ten -> + "🂪" + + Jack -> + "🂫" + + Queen -> + "🂭" + + King -> + "🂮" diff --git a/examples/src/Clock.elm b/examples/src/Clock.elm new file mode 100644 index 0000000000..42ab5a6ef6 --- /dev/null +++ b/examples/src/Clock.elm @@ -0,0 +1,135 @@ +module Clock exposing (main) + +-- Show an analog clock for your time zone. +-- +-- Dependencies: +-- elm install elm/svg +-- elm install elm/time +-- +-- For a simpler version, check out: +-- https://elm-lang.org/examples/time +-- + +import Browser +import Html exposing (Html) +import Svg exposing (..) +import Svg.Attributes exposing (..) +import Task +import Time + + + +-- MAIN + + +main = + Browser.element + { init = init + , view = view + , update = update + , subscriptions = subscriptions + } + + + +-- MODEL + + +type alias Model = + { zone : Time.Zone + , time : Time.Posix + } + + +init : () -> ( Model, Cmd Msg ) +init _ = + ( Model Time.utc (Time.millisToPosix 0) + , Cmd.batch + [ Task.perform AdjustTimeZone Time.here + , Task.perform Tick Time.now + ] + ) + + + +-- UPDATE + + +type Msg + = Tick Time.Posix + | AdjustTimeZone Time.Zone + + +update : Msg -> Model -> ( Model, Cmd Msg ) +update msg model = + case msg of + Tick newTime -> + ( { model | time = newTime } + , Cmd.none + ) + + AdjustTimeZone newZone -> + ( { model | zone = newZone } + , Cmd.none + ) + + + +-- SUBSCRIPTIONS + + +subscriptions : Model -> Sub Msg +subscriptions model = + Time.every 1000 Tick + + + +-- VIEW + + +view : Model -> Html Msg +view model = + let + hour = + toFloat (Time.toHour model.zone model.time) + + minute = + toFloat (Time.toMinute model.zone model.time) + + second = + toFloat (Time.toSecond model.zone model.time) + in + svg + [ viewBox "0 0 400 400" + , width "400" + , height "400" + ] + [ circle [ cx "200", cy "200", r "120", fill "#1293D8" ] [] + , viewHand 6 60 (hour / 12) + , viewHand 6 90 (minute / 60) + , viewHand 3 90 (second / 60) + ] + + +viewHand : Int -> Float -> Float -> Svg msg +viewHand width length turns = + let + t = + 2 * pi * (turns - 0.25) + + x = + 200 + length * cos t + + y = + 200 + length * sin t + in + line + [ x1 "200" + , y1 "200" + , x2 (String.fromFloat x) + , y2 (String.fromFloat y) + , stroke "white" + , strokeWidth (String.fromInt width) + , strokeLinecap "round" + ] + [] diff --git a/examples/src/Crate.elm b/examples/src/Crate.elm new file mode 100644 index 0000000000..55a97c312d --- /dev/null +++ b/examples/src/Crate.elm @@ -0,0 +1,228 @@ +module Crate exposing (..) + +-- Demonstrate how to load textures and put them on a cube. +-- +-- Dependencies: +-- elm install elm-explorations/linear-algebra +-- elm install elm-explorations/webgl +-- + +import Browser +import Browser.Events as E +import Html exposing (Html) +import Html.Attributes exposing (height, style, width) +import Math.Matrix4 as Mat4 exposing (Mat4) +import Math.Vector2 as Vec2 exposing (Vec2, vec2) +import Math.Vector3 as Vec3 exposing (Vec3, vec3) +import Result +import Task +import WebGL +import WebGL.Texture as Texture + + + +-- MAIN + + +main = + Browser.element + { init = init + , view = view + , update = \msg model -> ( update msg model, Cmd.none ) + , subscriptions = subscriptions + } + + + +-- MODEL + + +type alias Model = + { angle : Float + , texture : Maybe Texture.Texture + } + + +init : () -> ( Model, Cmd Msg ) +init () = + ( { angle = 0 + , texture = Nothing + } + , Task.attempt GotTexture (Texture.load "https://elm-lang.org/images/wood-crate.jpg") + ) + + + +-- UPDATE + + +type Msg + = TimeDelta Float + | GotTexture (Result Texture.Error Texture.Texture) + + +update : Msg -> Model -> Model +update msg model = + case msg of + TimeDelta dt -> + { model | angle = model.angle + dt / 5000 } + + GotTexture result -> + { model | texture = Result.toMaybe result } + + + +-- SUBSCRIPTIONS + + +subscriptions : Model -> Sub Msg +subscriptions _ = + E.onAnimationFrameDelta TimeDelta + + + +-- VIEW + + +view : Model -> Html Msg +view model = + case model.texture of + Nothing -> + Html.text "Loading texture..." + + Just texture -> + WebGL.toHtml + [ width 400 + , height 400 + , style "display" "block" + ] + [ WebGL.entity vertexShader fragmentShader crateMesh (toUniforms model.angle texture) + ] + + + +-- UNIFORMS + + +type alias Uniforms = + { rotation : Mat4 + , perspective : Mat4 + , camera : Mat4 + , texture : Texture.Texture + } + + +toUniforms : Float -> Texture.Texture -> Uniforms +toUniforms angle texture = + { rotation = + Mat4.mul + (Mat4.makeRotate (3 * angle) (vec3 0 1 0)) + (Mat4.makeRotate (2 * angle) (vec3 1 0 0)) + , perspective = perspective + , camera = camera + , texture = texture + } + + +perspective : Mat4 +perspective = + Mat4.makePerspective 45 1 0.01 100 + + +camera : Mat4 +camera = + Mat4.makeLookAt (vec3 0 0 5) (vec3 0 0 0) (vec3 0 1 0) + + + +-- MESH + + +type alias Vertex = + { position : Vec3 + , coord : Vec2 + } + + +crateMesh : WebGL.Mesh Vertex +crateMesh = + WebGL.triangles <| + List.concatMap rotatedSquare <| + [ ( 0, 0 ) + , ( 90, 0 ) + , ( 180, 0 ) + , ( 270, 0 ) + , ( 0, 90 ) + , ( 0, 270 ) + ] + + +rotatedSquare : ( Float, Float ) -> List ( Vertex, Vertex, Vertex ) +rotatedSquare ( angleXZ, angleYZ ) = + let + transformMat = + Mat4.mul + (Mat4.makeRotate (degrees angleXZ) Vec3.j) + (Mat4.makeRotate (degrees angleYZ) Vec3.i) + + transform vertex = + { vertex | position = Mat4.transform transformMat vertex.position } + + transformTriangle ( a, b, c ) = + ( transform a, transform b, transform c ) + in + List.map transformTriangle square + + +square : List ( Vertex, Vertex, Vertex ) +square = + let + topLeft = + Vertex (vec3 -1 1 1) (vec2 0 1) + + topRight = + Vertex (vec3 1 1 1) (vec2 1 1) + + bottomLeft = + Vertex (vec3 -1 -1 1) (vec2 0 0) + + bottomRight = + Vertex (vec3 1 -1 1) (vec2 1 0) + in + [ ( topLeft, topRight, bottomLeft ) + , ( bottomLeft, topRight, bottomRight ) + ] + + + +-- SHADERS + + +vertexShader : WebGL.Shader Vertex Uniforms { vcoord : Vec2 } +vertexShader = + [glsl| + attribute vec3 position; + attribute vec2 coord; + uniform mat4 perspective; + uniform mat4 camera; + uniform mat4 rotation; + varying vec2 vcoord; + + void main () { + gl_Position = perspective * camera * rotation * vec4(position, 1.0); + vcoord = coord; + } + |] + + +fragmentShader : WebGL.Shader {} Uniforms { vcoord : Vec2 } +fragmentShader = + [glsl| + precision mediump float; + uniform sampler2D texture; + varying vec2 vcoord; + + void main () { + gl_FragColor = texture2D(texture, vcoord); + } + |] diff --git a/examples/src/Cube.elm b/examples/src/Cube.elm new file mode 100644 index 0000000000..dcfed360c6 --- /dev/null +++ b/examples/src/Cube.elm @@ -0,0 +1,189 @@ +module Cube exposing (main) + +-- Render a spinning cube. +-- +-- Dependencies: +-- elm install elm-explorations/linear-algebra +-- elm install elm-explorations/webgl +-- + +import Browser +import Browser.Events as E +import Html exposing (Html) +import Html.Attributes exposing (height, style, width) +import Math.Matrix4 as Mat4 exposing (Mat4) +import Math.Vector3 as Vec3 exposing (Vec3, vec3) +import WebGL + + + +-- MAIN + + +main = + Browser.element + { init = init + , view = view + , update = update + , subscriptions = subscriptions + } + + + +-- MODEL + + +type alias Model = + Float + + +init : () -> ( Model, Cmd Msg ) +init () = + ( 0, Cmd.none ) + + + +-- UPDATE + + +type Msg + = TimeDelta Float + + +update : Msg -> Model -> ( Model, Cmd Msg ) +update msg angle = + case msg of + TimeDelta dt -> + ( angle + dt / 5000, Cmd.none ) + + + +-- SUBSCRIPTIONS + + +subscriptions : Model -> Sub Msg +subscriptions _ = + E.onAnimationFrameDelta TimeDelta + + + +-- VIEW + + +view : Model -> Html Msg +view angle = + WebGL.toHtml + [ width 400 + , height 400 + , style "display" "block" + ] + [ WebGL.entity vertexShader fragmentShader cubeMesh (uniforms angle) + ] + + +type alias Uniforms = + { rotation : Mat4 + , perspective : Mat4 + , camera : Mat4 + } + + +uniforms : Float -> Uniforms +uniforms angle = + { rotation = + Mat4.mul + (Mat4.makeRotate (3 * angle) (vec3 0 1 0)) + (Mat4.makeRotate (2 * angle) (vec3 1 0 0)) + , perspective = Mat4.makePerspective 45 1 0.01 100 + , camera = Mat4.makeLookAt (vec3 0 0 5) (vec3 0 0 0) (vec3 0 1 0) + } + + + +-- MESH + + +type alias Vertex = + { color : Vec3 + , position : Vec3 + } + + +cubeMesh : WebGL.Mesh Vertex +cubeMesh = + let + rft = + vec3 1 1 1 + + lft = + vec3 -1 1 1 + + lbt = + vec3 -1 -1 1 + + rbt = + vec3 1 -1 1 + + rbb = + vec3 1 -1 -1 + + rfb = + vec3 1 1 -1 + + lfb = + vec3 -1 1 -1 + + lbb = + vec3 -1 -1 -1 + in + WebGL.triangles <| + List.concat <| + [ face (vec3 115 210 22) rft rfb rbb rbt -- green + , face (vec3 52 101 164) rft rfb lfb lft -- blue + , face (vec3 237 212 0) rft lft lbt rbt -- yellow + , face (vec3 204 0 0) rfb lfb lbb rbb -- red + , face (vec3 117 80 123) lft lfb lbb lbt -- purple + , face (vec3 245 121 0) rbt rbb lbb lbt -- orange + ] + + +face : Vec3 -> Vec3 -> Vec3 -> Vec3 -> Vec3 -> List ( Vertex, Vertex, Vertex ) +face color a b c d = + let + vertex position = + Vertex (Vec3.scale (1 / 255) color) position + in + [ ( vertex a, vertex b, vertex c ) + , ( vertex c, vertex d, vertex a ) + ] + + + +-- SHADERS + + +vertexShader : WebGL.Shader Vertex Uniforms { vcolor : Vec3 } +vertexShader = + [glsl| + attribute vec3 position; + attribute vec3 color; + uniform mat4 perspective; + uniform mat4 camera; + uniform mat4 rotation; + varying vec3 vcolor; + void main () { + gl_Position = perspective * camera * rotation * vec4(position, 1.0); + vcolor = color; + } + |] + + +fragmentShader : WebGL.Shader {} Uniforms { vcolor : Vec3 } +fragmentShader = + [glsl| + precision mediump float; + varying vec3 vcolor; + void main () { + gl_FragColor = 0.8 * vec4(vcolor, 1.0); + } + |] diff --git a/examples/src/CurrentTime.elm b/examples/src/CurrentTime.elm new file mode 100644 index 0000000000..bd62a51f50 --- /dev/null +++ b/examples/src/CurrentTime.elm @@ -0,0 +1,96 @@ +module CurrentTime exposing (main) + +-- Show the current time in your time zone. +-- +-- Read how it works: +-- https://guide.elm-lang.org/effects/time.html +-- +-- For an analog clock, check out this SVG example: +-- https://elm-lang.org/examples/clock +-- + +import Browser +import Html exposing (..) +import Task +import Time + + + +-- MAIN + + +main = + Browser.element + { init = init + , view = view + , update = update + , subscriptions = subscriptions + } + + + +-- MODEL + + +type alias Model = + { zone : Time.Zone + , time : Time.Posix + } + + +init : () -> ( Model, Cmd Msg ) +init _ = + ( Model Time.utc (Time.millisToPosix 0) + , Task.perform AdjustTimeZone Time.here + ) + + + +-- UPDATE + + +type Msg + = Tick Time.Posix + | AdjustTimeZone Time.Zone + + +update : Msg -> Model -> ( Model, Cmd Msg ) +update msg model = + case msg of + Tick newTime -> + ( { model | time = newTime } + , Cmd.none + ) + + AdjustTimeZone newZone -> + ( { model | zone = newZone } + , Cmd.none + ) + + + +-- SUBSCRIPTIONS + + +subscriptions : Model -> Sub Msg +subscriptions model = + Time.every 1000 Tick + + + +-- VIEW + + +view : Model -> Html Msg +view model = + let + hour = + String.fromInt (Time.toHour model.zone model.time) + + minute = + String.fromInt (Time.toMinute model.zone model.time) + + second = + String.fromInt (Time.toSecond model.zone model.time) + in + h1 [] [ text (hour ++ ":" ++ minute ++ ":" ++ second) ] diff --git a/examples/src/DragAndDrop.elm b/examples/src/DragAndDrop.elm new file mode 100644 index 0000000000..80651eaee0 --- /dev/null +++ b/examples/src/DragAndDrop.elm @@ -0,0 +1,139 @@ +module DragAndDrop exposing (main) + +-- Image upload with a drag and drop zone. +-- +-- Dependencies: +-- elm install elm/file +-- elm install elm/json +-- + +import Browser +import File exposing (File) +import File.Select as Select +import Html exposing (..) +import Html.Attributes exposing (..) +import Html.Events exposing (..) +import Json.Decode as D + + + +-- MAIN + + +main = + Browser.element + { init = init + , view = view + , update = update + , subscriptions = subscriptions + } + + + +-- MODEL + + +type alias Model = + { hover : Bool + , files : List File + } + + +init : () -> ( Model, Cmd Msg ) +init _ = + ( Model False [], Cmd.none ) + + + +-- UPDATE + + +type Msg + = Pick + | DragEnter + | DragLeave + | GotFiles File (List File) + + +update : Msg -> Model -> ( Model, Cmd Msg ) +update msg model = + case msg of + Pick -> + ( model + , Select.files [ "image/*" ] GotFiles + ) + + DragEnter -> + ( { model | hover = True } + , Cmd.none + ) + + DragLeave -> + ( { model | hover = False } + , Cmd.none + ) + + GotFiles file files -> + ( { model + | files = file :: files + , hover = False + } + , Cmd.none + ) + + + +-- SUBSCRIPTIONS + + +subscriptions : Model -> Sub Msg +subscriptions model = + Sub.none + + + +-- VIEW + + +view : Model -> Html Msg +view model = + div + [ style "border" + (if model.hover then + "6px dashed purple" + + else + "6px dashed #ccc" + ) + , style "border-radius" "20px" + , style "width" "480px" + , style "height" "100px" + , style "margin" "100px auto" + , style "padding" "20px" + , style "display" "flex" + , style "flex-direction" "column" + , style "justify-content" "center" + , style "align-items" "center" + , hijackOn "dragenter" (D.succeed DragEnter) + , hijackOn "dragover" (D.succeed DragEnter) + , hijackOn "dragleave" (D.succeed DragLeave) + , hijackOn "drop" dropDecoder + ] + [ button [ onClick Pick ] [ text "Upload Images" ] + , span [ style "color" "#ccc" ] [ text (Debug.toString model) ] + ] + + +dropDecoder : D.Decoder Msg +dropDecoder = + D.at [ "dataTransfer", "files" ] (D.oneOrMore GotFiles File.decoder) + + +hijackOn : String -> D.Decoder msg -> Attribute msg +hijackOn event decoder = + preventDefaultOn event (D.map hijack decoder) + + +hijack : msg -> ( msg, Bool ) +hijack msg = + ( msg, True ) diff --git a/examples/src/FirstPerson.elm b/examples/src/FirstPerson.elm new file mode 100644 index 0000000000..a14dca978a --- /dev/null +++ b/examples/src/FirstPerson.elm @@ -0,0 +1,376 @@ +module FirstPerson exposing (main) + +-- Walk around in 3D space using the keyboard. +-- +-- Dependencies: +-- elm install elm-explorations/linear-algebra +-- elm install elm-explorations/webgl +-- +-- Try adding the ability to crouch or to land on top of the crate! +-- + +import Browser +import Browser.Dom as Dom +import Browser.Events as E +import Html exposing (Html, div, p, text) +import Html.Attributes exposing (height, style, width) +import Json.Decode as D +import Math.Matrix4 as Mat4 exposing (Mat4) +import Math.Vector2 as Vec2 exposing (Vec2, vec2) +import Math.Vector3 as Vec3 exposing (Vec3, vec3) +import Task +import WebGL +import WebGL.Texture as Texture + + + +-- MAIN + + +main : Program () Model Msg +main = + Browser.element + { init = init + , view = view + , update = \msg model -> ( update msg model, Cmd.none ) + , subscriptions = subscriptions + } + + + +-- MODEL + + +type alias Model = + { keys : Keys + , width : Float + , height : Float + , person : Person + , texture : Maybe Texture.Texture + } + + +type alias Keys = + { up : Bool + , left : Bool + , down : Bool + , right : Bool + , space : Bool + } + + +type alias Person = + { position : Vec3 + , velocity : Vec3 + } + + +init : () -> ( Model, Cmd Msg ) +init _ = + ( { keys = noKeys + , width = 400 + , height = 400 + , person = Person (vec3 0 eyeLevel -10) (vec3 0 0 0) + , texture = Nothing + } + , Cmd.batch + [ Task.attempt GotTexture (Texture.load "https://elm-lang.org/images/wood-crate.jpg") + , Task.perform (\{ viewport } -> Resized viewport.width viewport.height) Dom.getViewport + ] + ) + + +eyeLevel : Float +eyeLevel = + 2 + + +noKeys : Keys +noKeys = + Keys False False False False False + + + +-- UPDATE + + +type Msg + = GotTexture (Result Texture.Error Texture.Texture) + | KeyChanged Bool String + | TimeDelta Float + | Resized Float Float + | VisibilityChanged E.Visibility + + +update : Msg -> Model -> Model +update msg model = + case msg of + GotTexture result -> + { model | texture = Result.toMaybe result } + + KeyChanged isDown key -> + { model | keys = updateKeys isDown key model.keys } + + TimeDelta dt -> + { model | person = updatePerson dt model.keys model.person } + + Resized width height -> + { model + | width = width + , height = height + } + + VisibilityChanged _ -> + { model | keys = noKeys } + + +updateKeys : Bool -> String -> Keys -> Keys +updateKeys isDown key keys = + case key of + " " -> + { keys | space = isDown } + + "ArrowUp" -> + { keys | up = isDown } + + "ArrowLeft" -> + { keys | left = isDown } + + "ArrowDown" -> + { keys | down = isDown } + + "ArrowRight" -> + { keys | right = isDown } + + _ -> + keys + + +updatePerson : Float -> Keys -> Person -> Person +updatePerson dt keys person = + let + velocity = + stepVelocity dt keys person + + position = + Vec3.add person.position (Vec3.scale (dt / 500) velocity) + in + if Vec3.getY position < eyeLevel then + { position = Vec3.setY eyeLevel position + , velocity = Vec3.setY 0 velocity + } + + else + { position = position + , velocity = velocity + } + + +stepVelocity : Float -> Keys -> Person -> Vec3 +stepVelocity dt { left, right, up, down, space } person = + if Vec3.getY person.position > eyeLevel then + Vec3.setY (Vec3.getY person.velocity - dt / 250) person.velocity + + else + let + toV positive negative = + (if positive then + 1 + + else + 0 + ) + - (if negative then + 1 + + else + 0 + ) + in + vec3 (toV left right) + (if space then + 2 + + else + 0 + ) + (toV up down) + + + +-- SUBSCRIPTIONS + + +subscriptions : Model -> Sub Msg +subscriptions model = + Sub.batch + [ E.onResize (\w h -> Resized (toFloat w) (toFloat h)) + , E.onKeyUp (D.map (KeyChanged False) (D.field "key" D.string)) + , E.onKeyDown (D.map (KeyChanged True) (D.field "key" D.string)) + , E.onAnimationFrameDelta TimeDelta + , E.onVisibilityChange VisibilityChanged + ] + + + +-- VIEW + + +view : Model -> Html Msg +view model = + let + entities = + case model.texture of + Nothing -> + [] + + Just texture -> + [ viewCrate model.width model.height model.person texture ] + in + div + [ style "position" "absolute" + , style "left" "0" + , style "top" "0" + , style "width" (String.fromFloat model.width ++ "px") + , style "height" (String.fromFloat model.height ++ "px") + ] + [ WebGL.toHtmlWith [ WebGL.depth 1, WebGL.clearColor 1 1 1 1 ] + [ style "display" "block" + , width (round model.width) + , height (round model.height) + ] + entities + , keyboardInstructions model.keys + ] + + +viewCrate : Float -> Float -> Person -> Texture.Texture -> WebGL.Entity +viewCrate width height person texture = + let + perspective = + Mat4.mul + (Mat4.makePerspective 45 (width / height) 0.01 100) + (Mat4.makeLookAt person.position (Vec3.add person.position Vec3.k) Vec3.j) + in + WebGL.entity vertexShader + fragmentShader + crate + { texture = texture + , perspective = perspective + } + + +keyboardInstructions : Keys -> Html msg +keyboardInstructions keys = + div + [ style "position" "absolute" + , style "font-family" "monospace" + , style "text-align" "center" + , style "left" "20px" + , style "right" "20px" + , style "top" "20px" + ] + [ p [] [ text "Walk around with a first person perspective." ] + , p [] [ text "Arrows keys to move, space bar to jump." ] + ] + + + +-- MESH + + +type alias Vertex = + { position : Vec3 + , coord : Vec2 + } + + +crate : WebGL.Mesh Vertex +crate = + WebGL.triangles <| + List.concatMap rotatedSquare <| + [ ( 0, 0 ) + , ( 90, 0 ) + , ( 180, 0 ) + , ( 270, 0 ) + , ( 0, 90 ) + , ( 0, -90 ) + ] + + +rotatedSquare : ( Float, Float ) -> List ( Vertex, Vertex, Vertex ) +rotatedSquare ( angleXZ, angleYZ ) = + let + transformMat = + Mat4.mul + (Mat4.makeRotate (degrees angleXZ) Vec3.j) + (Mat4.makeRotate (degrees angleYZ) Vec3.i) + + transform vertex = + { vertex + | position = + Mat4.transform transformMat vertex.position + } + + transformTriangle ( a, b, c ) = + ( transform a, transform b, transform c ) + in + List.map transformTriangle square + + +square : List ( Vertex, Vertex, Vertex ) +square = + let + topLeft = + Vertex (vec3 -1 1 1) (vec2 0 1) + + topRight = + Vertex (vec3 1 1 1) (vec2 1 1) + + bottomLeft = + Vertex (vec3 -1 -1 1) (vec2 0 0) + + bottomRight = + Vertex (vec3 1 -1 1) (vec2 1 0) + in + [ ( topLeft, topRight, bottomLeft ) + , ( bottomLeft, topRight, bottomRight ) + ] + + + +-- SHADERS + + +type alias Uniforms = + { texture : Texture.Texture + , perspective : Mat4 + } + + +vertexShader : WebGL.Shader Vertex Uniforms { vcoord : Vec2 } +vertexShader = + [glsl| + attribute vec3 position; + attribute vec2 coord; + uniform mat4 perspective; + varying vec2 vcoord; + + void main () { + gl_Position = perspective * vec4(position, 1.0); + vcoord = coord; + } + |] + + +fragmentShader : WebGL.Shader {} Uniforms { vcoord : Vec2 } +fragmentShader = + [glsl| + precision mediump float; + uniform sampler2D texture; + varying vec2 vcoord; + + void main () { + gl_FragColor = texture2D(texture, vcoord); + } + |] diff --git a/examples/src/Forms.elm b/examples/src/Forms.elm new file mode 100644 index 0000000000..97d3dbd7de --- /dev/null +++ b/examples/src/Forms.elm @@ -0,0 +1,87 @@ +module Forms exposing (main) + +-- Input a user name and password. Make sure the password matches. +-- +-- Read how it works: +-- https://guide.elm-lang.org/architecture/forms.html +-- + +import Browser +import Html exposing (..) +import Html.Attributes exposing (..) +import Html.Events exposing (onInput) + + + +-- MAIN + + +main = + Browser.sandbox { init = init, update = update, view = view } + + + +-- MODEL + + +type alias Model = + { name : String + , password : String + , passwordAgain : String + } + + +init : Model +init = + Model "" "" "" + + + +-- UPDATE + + +type Msg + = Name String + | Password String + | PasswordAgain String + + +update : Msg -> Model -> Model +update msg model = + case msg of + Name name -> + { model | name = name } + + Password password -> + { model | password = password } + + PasswordAgain password -> + { model | passwordAgain = password } + + + +-- VIEW + + +view : Model -> Html Msg +view model = + div [] + [ viewInput "text" "Name" model.name Name + , viewInput "password" "Password" model.password Password + , viewInput "password" "Re-enter Password" model.passwordAgain PasswordAgain + , viewValidation model + ] + + +viewInput : String -> String -> String -> (String -> msg) -> Html msg +viewInput t p v toMsg = + input [ type_ t, placeholder p, value v, onInput toMsg ] [] + + +viewValidation : Model -> Html msg +viewValidation model = + if model.password == model.passwordAgain then + div [ style "color" "green" ] [ text "OK" ] + + else + div [ style "color" "red" ] [ text "Passwords do not match!" ] diff --git a/examples/src/Groceries.elm b/examples/src/Groceries.elm new file mode 100644 index 0000000000..80a55a13f5 --- /dev/null +++ b/examples/src/Groceries.elm @@ -0,0 +1,23 @@ +module Groceries exposing (main) + +-- Show a list of items I need to buy at the grocery store. +-- + +import Html exposing (..) + + +main = + div [] + [ h1 [] [ text "My Grocery List" ] + , ul [] + [ li [] [ text "Black Beans" ] + , li [] [ text "Limes" ] + , li [] [ text "Greek Yogurt" ] + , li [] [ text "Cilantro" ] + , li [] [ text "Honey" ] + , li [] [ text "Sweet Potatoes" ] + , li [] [ text "Cumin" ] + , li [] [ text "Chili Powder" ] + , li [] [ text "Quinoa" ] + ] + ] diff --git a/examples/src/Hello.elm b/examples/src/Hello.elm new file mode 100644 index 0000000000..1853bd11a5 --- /dev/null +++ b/examples/src/Hello.elm @@ -0,0 +1,7 @@ +module Hello exposing (main) + +import Html exposing (text) + + +main = + text "Hello!" diff --git a/examples/src/ImagePreviews.elm b/examples/src/ImagePreviews.elm new file mode 100644 index 0000000000..c92e300d5a --- /dev/null +++ b/examples/src/ImagePreviews.elm @@ -0,0 +1,163 @@ +module ImagePreviews exposing (main) + +-- Image upload with a drag and drop zone. See image previews! +-- +-- Dependencies: +-- elm install elm/file +-- elm install elm/json +-- + +import Browser +import File exposing (File) +import File.Select as Select +import Html exposing (..) +import Html.Attributes exposing (..) +import Html.Events exposing (..) +import Json.Decode as D +import Task + + + +-- MAIN + + +main = + Browser.element + { init = init + , view = view + , update = update + , subscriptions = subscriptions + } + + + +-- MODEL + + +type alias Model = + { hover : Bool + , previews : List String + } + + +init : () -> ( Model, Cmd Msg ) +init _ = + ( Model False [], Cmd.none ) + + + +-- UPDATE + + +type Msg + = Pick + | DragEnter + | DragLeave + | GotFiles File (List File) + | GotPreviews (List String) + + +update : Msg -> Model -> ( Model, Cmd Msg ) +update msg model = + case msg of + Pick -> + ( model + , Select.files [ "image/*" ] GotFiles + ) + + DragEnter -> + ( { model | hover = True } + , Cmd.none + ) + + DragLeave -> + ( { model | hover = False } + , Cmd.none + ) + + GotFiles file files -> + ( { model | hover = False } + , Task.perform GotPreviews <| + Task.sequence <| + List.map File.toUrl (file :: files) + ) + + GotPreviews urls -> + ( { model | previews = urls } + , Cmd.none + ) + + + +-- SUBSCRIPTIONS + + +subscriptions : Model -> Sub Msg +subscriptions model = + Sub.none + + + +-- VIEW + + +view : Model -> Html Msg +view model = + div + [ style "border" + (if model.hover then + "6px dashed purple" + + else + "6px dashed #ccc" + ) + , style "border-radius" "20px" + , style "width" "480px" + , style "margin" "100px auto" + , style "padding" "40px" + , style "display" "flex" + , style "flex-direction" "column" + , style "justify-content" "center" + , style "align-items" "center" + , hijackOn "dragenter" (D.succeed DragEnter) + , hijackOn "dragover" (D.succeed DragEnter) + , hijackOn "dragleave" (D.succeed DragLeave) + , hijackOn "drop" dropDecoder + ] + [ button [ onClick Pick ] [ text "Upload Images" ] + , div + [ style "display" "flex" + , style "align-items" "center" + , style "height" "60px" + , style "padding" "20px" + ] + (List.map viewPreview model.previews) + ] + + +viewPreview : String -> Html msg +viewPreview url = + div + [ style "width" "60px" + , style "height" "60px" + , style "background-image" ("url('" ++ url ++ "')") + , style "background-position" "center" + , style "background-repeat" "no-repeat" + , style "background-size" "contain" + ] + [] + + +dropDecoder : D.Decoder Msg +dropDecoder = + D.at [ "dataTransfer", "files" ] (D.oneOrMore GotFiles File.decoder) + + +hijackOn : String -> D.Decoder msg -> Attribute msg +hijackOn event decoder = + preventDefaultOn event (D.map hijack decoder) + + +hijack : msg -> ( msg, Bool ) +hijack msg = + ( msg, True ) diff --git a/examples/src/Keyboard.elm b/examples/src/Keyboard.elm new file mode 100644 index 0000000000..a3e6752b00 --- /dev/null +++ b/examples/src/Keyboard.elm @@ -0,0 +1,26 @@ +module Keyboard exposing (main) + +-- Move a square around with the arrow keys: UP, DOWN, LEFT, RIGHT +-- Try making it move around more quickly! +-- +-- Learn more about the playground here: +-- https://package.elm-lang.org/packages/evancz/elm-playground/latest/ +-- + +import Playground exposing (..) + + +main = + game view update ( 0, 0 ) + + +view computer ( x, y ) = + [ square blue 40 + |> move x y + ] + + +update computer ( x, y ) = + ( x + toX computer.keyboard + , y + toY computer.keyboard + ) diff --git a/examples/src/Mario.elm b/examples/src/Mario.elm new file mode 100644 index 0000000000..2e8a889db0 --- /dev/null +++ b/examples/src/Mario.elm @@ -0,0 +1,103 @@ +module Mario exposing (main) + +-- Walk around with the arrow keys. Press the UP arrow to jump! +-- +-- Learn more about the playground here: +-- https://package.elm-lang.org/packages/evancz/elm-playground/latest/ +-- + +import Playground exposing (..) + + + +-- MAIN + + +main = + game view + update + { x = 0 + , y = 0 + , vx = 0 + , vy = 0 + , dir = "right" + } + + + +-- VIEW + + +view computer mario = + let + w = + computer.screen.width + + h = + computer.screen.height + + b = + computer.screen.bottom + in + [ rectangle (rgb 174 238 238) w h + , rectangle (rgb 74 163 41) w 100 + |> moveY b + , image 70 70 (toGif mario) + |> move mario.x (b + 76 + mario.y) + ] + + +toGif mario = + if mario.y > 0 then + "https://elm-lang.org/images/mario/jump/" ++ mario.dir ++ ".gif" + + else if mario.vx /= 0 then + "https://elm-lang.org/images/mario/walk/" ++ mario.dir ++ ".gif" + + else + "https://elm-lang.org/images/mario/stand/" ++ mario.dir ++ ".gif" + + + +-- UPDATE + + +update computer mario = + let + dt = + 1.666 + + vx = + toX computer.keyboard + + vy = + if mario.y == 0 then + if computer.keyboard.up then + 5 + + else + 0 + + else + mario.vy - dt / 8 + + x = + mario.x + dt * vx + + y = + mario.y + dt * vy + in + { x = x + , y = max 0 y + , vx = vx + , vy = vy + , dir = + if vx == 0 then + mario.dir + + else if vx < 0 then + "left" + + else + "right" + } diff --git a/examples/src/Mouse.elm b/examples/src/Mouse.elm new file mode 100644 index 0000000000..ed30453a8a --- /dev/null +++ b/examples/src/Mouse.elm @@ -0,0 +1,31 @@ +module Mouse exposing (main) + +-- Draw a cicle around the mouse. Change its color by pressing down. +-- +-- Learn more about the playground here: +-- https://package.elm-lang.org/packages/evancz/elm-playground/latest/ +-- + +import Playground exposing (..) + + +main = + game view update () + + +view computer memory = + [ circle lightPurple 30 + |> moveX computer.mouse.x + |> moveY computer.mouse.y + |> fade + (if computer.mouse.down then + 0.2 + + else + 1 + ) + ] + + +update computer memory = + memory diff --git a/examples/src/Numbers.elm b/examples/src/Numbers.elm new file mode 100644 index 0000000000..5af8b6fa09 --- /dev/null +++ b/examples/src/Numbers.elm @@ -0,0 +1,85 @@ +module Numbers exposing (main) + +-- Press a button to generate a random number between 1 and 6. +-- +-- Read how it works: +-- https://guide.elm-lang.org/effects/random.html +-- + +import Browser +import Html exposing (..) +import Html.Events exposing (..) +import Random + + + +-- MAIN + + +main = + Browser.element + { init = init + , update = update + , subscriptions = subscriptions + , view = view + } + + + +-- MODEL + + +type alias Model = + { dieFace : Int + } + + +init : () -> ( Model, Cmd Msg ) +init _ = + ( Model 1 + , Cmd.none + ) + + + +-- UPDATE + + +type Msg + = Roll + | NewFace Int + + +update : Msg -> Model -> ( Model, Cmd Msg ) +update msg model = + case msg of + Roll -> + ( model + , Random.generate NewFace (Random.int 1 6) + ) + + NewFace newFace -> + ( Model newFace + , Cmd.none + ) + + + +-- SUBSCRIPTIONS + + +subscriptions : Model -> Sub Msg +subscriptions model = + Sub.none + + + +-- VIEW + + +view : Model -> Html Msg +view model = + div [] + [ h1 [] [ text (String.fromInt model.dieFace) ] + , button [ onClick Roll ] [ text "Roll" ] + ] diff --git a/examples/src/NumericSeparators.guida b/examples/src/NumericSeparators.guida new file mode 100644 index 0000000000..67db7e4d78 --- /dev/null +++ b/examples/src/NumericSeparators.guida @@ -0,0 +1,63 @@ +module NumericSeparators exposing (main) + +import Html exposing (div, table, td, text, tr) +import Html.Attributes exposing (style) + + +ints : List ( String, Int ) +ints = + [ ( "2_000", 2_000 ) + , ( "42_000_000", 42_000_000 ) + ] + + +floats : List ( String, Float ) +floats = + [ ( "111_000.602", 111_000.602 ) + , ( "1_000.4_205", 1_000.4_205 ) + , ( "0.000_1", 0.000_1 ) + , ( "0.000_000_1", 0.000_000_1 ) + ] + + +hexadecimals : List ( String, Int ) +hexadecimals = + [ ( "0x1F_2A", 0x1F_2A ) + , ( "0xDEADBEEF", 0xDEADBEEF ) + , ( "0xDE_AD_BE_EF", 0xDE_AD_BE_EF ) + ] + +binaries : List ( String, Int ) +binaries = + [ ( "0b1010", 0b1010 ) + , ( "0b01010110_00111000", 0b01010110_00111000 ) + , ( "0b0101_0110_0011_1000", 0b0101_0110_0011_1000 ) + ] + + +tableRow : (a -> String) -> ( String, a ) -> Html.Html msg +tableRow toString ( label, value ) = + tr [] + [ td [ style "min-width" "150px", style "padding" "7px" ] [ text label ] + , td [ style "min-width" "150px", style "padding" "7px" ] [ text (toString value) ] + ] + + +main = + div + [ style "width" "100%" + , style "width" "100%" + , style "display" "flex" + , style "justify-content" "center" + , style "align-item" "center" + ] + [ table + [ style "margin" "150px" + , style "padding" "20px" + ] + (List.map (tableRow String.fromInt) ints + ++ List.map (tableRow String.fromFloat) floats + ++ List.map (tableRow String.fromInt) hexadecimals + ++ List.map (tableRow String.fromInt) binaries + ) + ] diff --git a/examples/src/Picture.elm b/examples/src/Picture.elm new file mode 100644 index 0000000000..d767383be9 --- /dev/null +++ b/examples/src/Picture.elm @@ -0,0 +1,18 @@ +module Picture exposing (main) + +-- Create pictures from simple shapes. Like a tree! +-- +-- Learn more about the playground here: +-- https://package.elm-lang.org/packages/evancz/elm-playground/latest/ +-- + +import Playground exposing (..) + + +main = + picture + [ rectangle brown 40 200 + |> moveDown 80 + , circle green 100 + |> moveUp 100 + ] diff --git a/examples/src/Positions.elm b/examples/src/Positions.elm new file mode 100644 index 0000000000..568c7cf34b --- /dev/null +++ b/examples/src/Positions.elm @@ -0,0 +1,97 @@ +module Positions exposing (main) + +-- A button that moves to random positions when pressed. +-- +-- Dependencies: +-- elm install elm/random +-- + +import Browser +import Html exposing (..) +import Html.Attributes exposing (..) +import Html.Events exposing (..) +import Random + + + +-- MAIN + + +main = + Browser.element + { init = init + , update = update + , subscriptions = subscriptions + , view = view + } + + + +-- MODEL + + +type alias Model = + { x : Int + , y : Int + } + + +init : () -> ( Model, Cmd Msg ) +init _ = + ( Model 100 100 + , Cmd.none + ) + + + +-- UPDATE + + +type Msg + = Clicked + | NewPosition ( Int, Int ) + + +update : Msg -> Model -> ( Model, Cmd Msg ) +update msg model = + case msg of + Clicked -> + ( model + , Random.generate NewPosition positionGenerator + ) + + NewPosition ( x, y ) -> + ( Model x y + , Cmd.none + ) + + +positionGenerator : Random.Generator ( Int, Int ) +positionGenerator = + Random.map2 Tuple.pair + (Random.int 50 350) + (Random.int 50 350) + + + +-- SUBSCRIPTIONS + + +subscriptions : Model -> Sub Msg +subscriptions model = + Sub.none + + + +-- VIEW + + +view : Model -> Html Msg +view model = + button + [ style "position" "absolute" + , style "top" (String.fromInt model.x ++ "px") + , style "left" (String.fromInt model.y ++ "px") + , onClick Clicked + ] + [ text "Click me!" ] diff --git a/examples/src/Quotes.elm b/examples/src/Quotes.elm new file mode 100644 index 0000000000..c0a03490a1 --- /dev/null +++ b/examples/src/Quotes.elm @@ -0,0 +1,140 @@ +module Quotes exposing (main) + +-- Press a button to send a GET request for random quotes. +-- +-- Read how it works: +-- https://guide.elm-lang.org/effects/json.html +-- + +import Browser +import Html exposing (..) +import Html.Attributes exposing (style) +import Html.Events exposing (..) +import Http +import Json.Decode exposing (Decoder, field, int, map4, string) + + + +-- MAIN + + +main = + Browser.element + { init = init + , update = update + , subscriptions = subscriptions + , view = view + } + + + +-- MODEL + + +type Model + = Failure + | Loading + | Success Quote + + +type alias Quote = + { quote : String + , source : String + , author : String + , year : Int + } + + +init : () -> ( Model, Cmd Msg ) +init _ = + ( Loading, getRandomQuote ) + + + +-- UPDATE + + +type Msg + = MorePlease + | GotQuote (Result Http.Error Quote) + + +update : Msg -> Model -> ( Model, Cmd Msg ) +update msg model = + case msg of + MorePlease -> + ( Loading, getRandomQuote ) + + GotQuote result -> + case result of + Ok quote -> + ( Success quote, Cmd.none ) + + Err _ -> + ( Failure, Cmd.none ) + + + +-- SUBSCRIPTIONS + + +subscriptions : Model -> Sub Msg +subscriptions model = + Sub.none + + + +-- VIEW + + +view : Model -> Html Msg +view model = + div [] + [ h2 [] [ text "Random Quotes" ] + , viewQuote model + ] + + +viewQuote : Model -> Html Msg +viewQuote model = + case model of + Failure -> + div [] + [ text "I could not load a random quote for some reason. " + , button [ onClick MorePlease ] [ text "Try Again!" ] + ] + + Loading -> + text "Loading..." + + Success quote -> + div [] + [ button [ onClick MorePlease, style "display" "block" ] [ text "More Please!" ] + , blockquote [] [ text quote.quote ] + , p [ style "text-align" "right" ] + [ text "— " + , cite [] [ text quote.source ] + , text (" by " ++ quote.author ++ " (" ++ String.fromInt quote.year ++ ")") + ] + ] + + + +-- HTTP + + +getRandomQuote : Cmd Msg +getRandomQuote = + Http.get + { url = "https://elm-lang.org/api/random-quotes" + , expect = Http.expectJson GotQuote quoteDecoder + } + + +quoteDecoder : Decoder Quote +quoteDecoder = + map4 Quote + (field "quote" string) + (field "source" string) + (field "author" string) + (field "year" int) diff --git a/examples/src/Shapes.elm b/examples/src/Shapes.elm new file mode 100644 index 0000000000..8ba7d19e6a --- /dev/null +++ b/examples/src/Shapes.elm @@ -0,0 +1,80 @@ +module Shapes exposing (main) + +-- Scalable Vector Graphics (SVG) can be a nice way to draw things in 2D. +-- Here are some common SVG shapes. +-- +-- Dependencies: +-- elm install elm/svg +-- + +import Html exposing (Html) +import Svg exposing (..) +import Svg.Attributes exposing (..) + + +main : Html msg +main = + svg + [ viewBox "0 0 400 400" + , width "400" + , height "400" + ] + [ circle + [ cx "50" + , cy "50" + , r "40" + , fill "red" + , stroke "black" + , strokeWidth "3" + ] + [] + , rect + [ x "100" + , y "10" + , width "40" + , height "40" + , fill "green" + , stroke "black" + , strokeWidth "2" + ] + [] + , line + [ x1 "20" + , y1 "200" + , x2 "200" + , y2 "20" + , stroke "blue" + , strokeWidth "10" + , strokeLinecap "round" + ] + [] + , polyline + [ points "200,40 240,40 240,80 280,80 280,120 320,120 320,160" + , fill "none" + , stroke "red" + , strokeWidth "4" + , strokeDasharray "20,2" + ] + [] + , text_ + [ x "130" + , y "130" + , fill "black" + , textAnchor "middle" + , dominantBaseline "central" + , transform "rotate(-45 130,130)" + ] + [ text "Welcome to Shapes Club" + ] + ] + + + +-- There are a lot of odd things about SVG, so always try to find examples +-- to help you understand the weird stuff. Like these: +-- +-- https://www.w3schools.com/graphics/svg_examples.asp +-- https://developer.mozilla.org/en-US/docs/Web/SVG/Attribute/d +-- +-- If you cannot find relevant examples, make an experiment. If you push +-- through the weirdness, you can do a lot with SVG. diff --git a/examples/src/TextFields.elm b/examples/src/TextFields.elm new file mode 100644 index 0000000000..ba13e9221b --- /dev/null +++ b/examples/src/TextFields.elm @@ -0,0 +1,61 @@ +module TextFields exposing (main) + +-- A text input for reversing text. Very useful! +-- +-- Read how it works: +-- https://guide.elm-lang.org/architecture/text_fields.html +-- + +import Browser +import Html exposing (Attribute, Html, div, input, text) +import Html.Attributes exposing (..) +import Html.Events exposing (onInput) + + + +-- MAIN + + +main = + Browser.sandbox { init = init, update = update, view = view } + + + +-- MODEL + + +type alias Model = + { content : String + } + + +init : Model +init = + { content = "" } + + + +-- UPDATE + + +type Msg + = Change String + + +update : Msg -> Model -> Model +update msg model = + case msg of + Change newContent -> + { model | content = newContent } + + + +-- VIEW + + +view : Model -> Html Msg +view model = + div [] + [ input [ placeholder "Text to reverse", value model.content, onInput Change ] [] + , div [] [ text (String.reverse model.content) ] + ] diff --git a/examples/src/Thwomp.elm b/examples/src/Thwomp.elm new file mode 100644 index 0000000000..4258b332e8 --- /dev/null +++ b/examples/src/Thwomp.elm @@ -0,0 +1,296 @@ +module Thwomp exposing (main) + +-- Thwomp looks at your mouse. What is it up to? +-- +-- Dependencies: +-- elm install elm/json +-- elm install elm-explorations/linear-algebra +-- elm install elm-explorations/webgl +-- +-- Thanks to The PaperNES Guy for the texture: +-- https://the-papernes-guy.deviantart.com/art/Thwomps-Thwomps-Thwomps-186879685 + +import Browser +import Browser.Dom as Dom +import Browser.Events as E +import Html exposing (Html) +import Html.Attributes exposing (height, style, width) +import Json.Decode as D +import Math.Matrix4 as Mat4 exposing (Mat4) +import Math.Vector2 as Vec2 exposing (Vec2, vec2) +import Math.Vector3 as Vec3 exposing (Vec3, vec3) +import Result +import Task +import WebGL +import WebGL.Texture as Texture + + + +-- MAIN + + +main : Program () Model Msg +main = + Browser.element + { init = init + , view = view + , update = \msg model -> ( update msg model, Cmd.none ) + , subscriptions = subscriptions + } + + + +-- MODEL + + +type alias Model = + { width : Float + , height : Float + , x : Float + , y : Float + , side : Maybe Texture.Texture + , face : Maybe Texture.Texture + } + + +init : () -> ( Model, Cmd Msg ) +init _ = + ( { width = 0 + , height = 0 + , x = 0 + , y = 0 + , face = Nothing + , side = Nothing + } + , Cmd.batch + [ Task.perform GotViewport Dom.getViewport + , Task.attempt GotFace (Texture.loadWith options "https://elm-lang.org/images/thwomp-face.jpg") + , Task.attempt GotSide (Texture.loadWith options "https://elm-lang.org/images/thwomp-side.jpg") + ] + ) + + +options : Texture.Options +options = + { magnify = Texture.nearest + , minify = Texture.nearest + , horizontalWrap = Texture.repeat + , verticalWrap = Texture.repeat + , flipY = True + } + + + +-- UPDATE + + +type Msg + = GotFace (Result Texture.Error Texture.Texture) + | GotSide (Result Texture.Error Texture.Texture) + | GotViewport Dom.Viewport + | Resized Int Int + | MouseMoved Float Float + + +update : Msg -> Model -> Model +update msg model = + case msg of + GotFace result -> + { model + | face = Result.toMaybe result + } + + GotSide result -> + { model + | side = Result.toMaybe result + } + + GotViewport { viewport } -> + { model + | width = viewport.width + , height = viewport.height + } + + Resized width height -> + { model + | width = toFloat width + , height = toFloat height + } + + MouseMoved x y -> + { model + | x = x + , y = y + } + + + +-- SUBSCRIPTIONS + + +subscriptions : Model -> Sub Msg +subscriptions _ = + Sub.batch + [ E.onResize Resized + , E.onMouseMove decodeMovement + ] + + +decodeMovement : D.Decoder Msg +decodeMovement = + D.map2 MouseMoved + (D.field "pageX" D.float) + (D.field "pageY" D.float) + + + +-- VIEW + + +view : Model -> Html Msg +view model = + case Maybe.map2 Tuple.pair model.face model.side of + Nothing -> + Html.text "Loading textures..." + + Just ( face, side ) -> + let + perspective = + toPerspective model.x model.y model.width model.height + in + WebGL.toHtml + [ style "display" "block" + , style "position" "absolute" + , style "left" "0" + , style "top" "0" + , width (round model.width) + , height (round model.height) + ] + [ WebGL.entity vertexShader + fragmentShader + faceMesh + { perspective = perspective + , texture = face + } + , WebGL.entity vertexShader + fragmentShader + sidesMesh + { perspective = perspective + , texture = side + } + ] + + +toPerspective : Float -> Float -> Float -> Float -> Mat4 +toPerspective x y width height = + let + eye = + Vec3.scale 6 <| + Vec3.normalize <| + vec3 (0.5 - x / width) (y / height - 0.5) 1 + in + Mat4.mul + (Mat4.makePerspective 45 (width / height) 0.01 100) + (Mat4.makeLookAt eye (vec3 0 0 0) Vec3.j) + + + +-- MESHES + + +type alias Vertex = + { position : Vec3 + , coord : Vec2 + } + + +faceMesh : WebGL.Mesh Vertex +faceMesh = + WebGL.triangles square + + +sidesMesh : WebGL.Mesh Vertex +sidesMesh = + WebGL.triangles <| + List.concatMap rotatedSquare <| + [ ( 90, 0 ) + , ( 180, 0 ) + , ( 270, 0 ) + , ( 0, 90 ) + , ( 0, 270 ) + ] + + +rotatedSquare : ( Float, Float ) -> List ( Vertex, Vertex, Vertex ) +rotatedSquare ( angleXZ, angleYZ ) = + let + transformMat = + Mat4.mul + (Mat4.makeRotate (degrees angleXZ) Vec3.j) + (Mat4.makeRotate (degrees angleYZ) Vec3.i) + + transform vertex = + { vertex | position = Mat4.transform transformMat vertex.position } + + transformTriangle ( a, b, c ) = + ( transform a, transform b, transform c ) + in + List.map transformTriangle square + + +square : List ( Vertex, Vertex, Vertex ) +square = + let + topLeft = + Vertex (vec3 -1 1 1) (vec2 0 1) + + topRight = + Vertex (vec3 1 1 1) (vec2 1 1) + + bottomLeft = + Vertex (vec3 -1 -1 1) (vec2 0 0) + + bottomRight = + Vertex (vec3 1 -1 1) (vec2 1 0) + in + [ ( topLeft, topRight, bottomLeft ) + , ( bottomLeft, topRight, bottomRight ) + ] + + + +-- SHADERS + + +type alias Uniforms = + { perspective : Mat4 + , texture : Texture.Texture + } + + +vertexShader : WebGL.Shader Vertex Uniforms { vcoord : Vec2 } +vertexShader = + [glsl| + attribute vec3 position; + attribute vec2 coord; + uniform mat4 perspective; + varying vec2 vcoord; + + void main () { + gl_Position = perspective * vec4(position, 1.0); + vcoord = coord.xy; + } + |] + + +fragmentShader : WebGL.Shader {} Uniforms { vcoord : Vec2 } +fragmentShader = + [glsl| + precision mediump float; + uniform sampler2D texture; + varying vec2 vcoord; + + void main () { + gl_FragColor = texture2D(texture, vcoord); + } + |] diff --git a/examples/src/Triangle.elm b/examples/src/Triangle.elm new file mode 100644 index 0000000000..751bf9edbb --- /dev/null +++ b/examples/src/Triangle.elm @@ -0,0 +1,140 @@ +module Triangle exposing (main) + +-- elm install elm-explorations/linear-algebra +-- elm install elm-explorations/webgl + +import Browser +import Browser.Events as E +import Html exposing (Html) +import Html.Attributes exposing (height, style, width) +import Math.Matrix4 as Mat4 exposing (Mat4) +import Math.Vector3 as Vec3 exposing (Vec3, vec3) +import WebGL + + + +-- MAIN + + +main = + Browser.element + { init = init + , view = view + , update = update + , subscriptions = subscriptions + } + + + +-- MODEL + + +type alias Model = + Float + + +init : () -> ( Model, Cmd Msg ) +init () = + ( 0, Cmd.none ) + + + +-- UPDATE + + +type Msg + = TimeDelta Float + + +update : Msg -> Model -> ( Model, Cmd Msg ) +update msg currentTime = + case msg of + TimeDelta delta -> + ( delta + currentTime, Cmd.none ) + + + +-- SUBSCRIPTIONS + + +subscriptions : Model -> Sub Msg +subscriptions _ = + E.onAnimationFrameDelta TimeDelta + + + +-- VIEW + + +view : Model -> Html msg +view t = + WebGL.toHtml + [ width 400 + , height 400 + , style "display" "block" + ] + [ WebGL.entity vertexShader fragmentShader mesh { perspective = perspective (t / 1000) } + ] + + +perspective : Float -> Mat4 +perspective t = + Mat4.mul + (Mat4.makePerspective 45 1 0.01 100) + (Mat4.makeLookAt (vec3 (4 * cos t) 0 (4 * sin t)) (vec3 0 0 0) (vec3 0 1 0)) + + + +-- MESH + + +type alias Vertex = + { position : Vec3 + , color : Vec3 + } + + +mesh : WebGL.Mesh Vertex +mesh = + WebGL.triangles + [ ( Vertex (vec3 0 0 0) (vec3 1 0 0) + , Vertex (vec3 1 1 0) (vec3 0 1 0) + , Vertex (vec3 1 -1 0) (vec3 0 0 1) + ) + ] + + + +-- SHADERS + + +type alias Uniforms = + { perspective : Mat4 + } + + +vertexShader : WebGL.Shader Vertex Uniforms { vcolor : Vec3 } +vertexShader = + [glsl| + attribute vec3 position; + attribute vec3 color; + uniform mat4 perspective; + varying vec3 vcolor; + + void main () { + gl_Position = perspective * vec4(position, 1.0); + vcolor = color; + } + |] + + +fragmentShader : WebGL.Shader {} Uniforms { vcolor : Vec3 } +fragmentShader = + [glsl| + precision mediump float; + varying vec3 vcolor; + + void main () { + gl_FragColor = vec4(vcolor, 1.0); + } + |] diff --git a/examples/src/Turtle.elm b/examples/src/Turtle.elm new file mode 100644 index 0000000000..f10e4aab92 --- /dev/null +++ b/examples/src/Turtle.elm @@ -0,0 +1,35 @@ +module Turtle exposing (main) + +-- Use arrow keys to move the turtle around. +-- +-- Forward with UP and turn with LEFT and RIGHT. +-- +-- Learn more about the playground here: +-- https://package.elm-lang.org/packages/evancz/elm-playground/latest/ +-- + +import Playground exposing (..) + + +main = + game view + update + { x = 0 + , y = 0 + , angle = 0 + } + + +view computer turtle = + [ rectangle blue computer.screen.width computer.screen.height + , image 96 96 "https://elm-lang.org/images/turtle.gif" + |> move turtle.x turtle.y + |> rotate turtle.angle + ] + + +update computer turtle = + { x = turtle.x + toY computer.keyboard * cos (degrees turtle.angle) + , y = turtle.y + toY computer.keyboard * sin (degrees turtle.angle) + , angle = turtle.angle - toX computer.keyboard + } diff --git a/examples/src/Upload.elm b/examples/src/Upload.elm new file mode 100644 index 0000000000..13f3925e46 --- /dev/null +++ b/examples/src/Upload.elm @@ -0,0 +1,87 @@ +module Upload exposing (main) + +-- File upload with the node. +-- +-- Dependencies: +-- elm install elm/file +-- elm install elm/json +-- + +import Browser +import File exposing (File) +import Html exposing (..) +import Html.Attributes exposing (..) +import Html.Events exposing (..) +import Json.Decode as D + + + +-- MAIN + + +main = + Browser.element + { init = init + , view = view + , update = update + , subscriptions = subscriptions + } + + + +-- MODEL + + +type alias Model = + List File + + +init : () -> ( Model, Cmd Msg ) +init _ = + ( [], Cmd.none ) + + + +-- UPDATE + + +type Msg + = GotFiles (List File) + + +update : Msg -> Model -> ( Model, Cmd Msg ) +update msg model = + case msg of + GotFiles files -> + ( files, Cmd.none ) + + + +-- SUBSCRIPTIONS + + +subscriptions : Model -> Sub Msg +subscriptions model = + Sub.none + + + +-- VIEW + + +view : Model -> Html Msg +view model = + div [] + [ input + [ type_ "file" + , multiple True + , on "change" (D.map GotFiles filesDecoder) + ] + [] + , div [] [ text (Debug.toString model) ] + ] + + +filesDecoder : D.Decoder (List File) +filesDecoder = + D.at [ "target", "files" ] (D.list File.decoder) diff --git a/hints/bad-recursion.md b/hints/bad-recursion.md deleted file mode 100644 index 8a8cdc5af6..0000000000 --- a/hints/bad-recursion.md +++ /dev/null @@ -1,133 +0,0 @@ - -# Hints for Bad Recursion - -There are two problems that will lead you here, both of them pretty tricky: - - 1. [**No Mutation**](#no-mutation) — Defining values in Elm is slightly different than defining values in languages like JavaScript. - - 2. [**Tricky Recursion**](#tricky-recursion) — Sometimes you need to define recursive values when creating generators, decoders, and parsers. A common case is a JSON decoder a discussion forums where a comment may have replies, which may have replies, which may have replies, etc. - - -## No Mutation - -Languages like JavaScript let you “reassign” variables. When you say `x = x + 1` it means: whatever `x` was pointing to, have it point to `x + 1` instead. This called *mutating* a variable. All values are immutable in Elm, so reassigning variables does not make any sense! Okay, so what *should* `x = x + 1` mean in Elm? - -Well, what does it mean with functions? In Elm, we write recursive functions like this: - -```elm -factorial : Int -> Int -factorial n = - if n <= 0 then 1 else n * factorial (n - 1) -``` - -One cool thing about Elm is that whenever you see `factorial 3`, you can always replace that expression with `if 3 <= 0 then 1 else 3 * factorial (3 - 1)` and it will work exactly the same. So when Elm code gets evaluated, we will keep expanding `factorial` until the `if` produces a 1. At that point, we are done expanding and move on. - -The thing that surprises newcomers is that recursion works the same way with values too. So take the following definition: - -```elm -x = x + 1 -``` - -We are actually defining `x` in terms of itself. So it would expand out to `x = ... + 1 + 1 + 1 + 1`, trying to add one to `x` an infinite number of times! This means your program would just run forever, endlessly expanding `x`. In practice, this means the page freezes and the computer starts to get kind of warm. No good! We can detect cases like this with the compiler, so we give an error at compile time so this does not happen in the wild. - -The fix is usually to just give the new value a new name. So you could rewrite it to: - -```elm -x1 = x + 1 -``` - -Now `x` is the old value and `x1` is the new value. Again, one cool thing about Elm is that whenever you see a `factorial 3` you can safely replace it with its definition. Well, the same is true of values. Wherever I see `x1`, I can replace it with `x + 1`. Thanks to the way definitions work in Elm, this is always safe! - - -## Tricky Recursion - -Now, there are some cases where you *do* want a recursive value. Say you are building a website with comments and replies. You may define a comment like this: - -```elm -type alias Comment = - { message : String - , upvotes : Int - , downvotes : Int - , responses : Responses - } - -type Responses = - Responses (List Comment) -``` - -You may have run into this definition in the [hints for recursive aliases](recursive-alias.md)! Anyway, once you have comments, you may want to turn them into JSON to send back to your server or to store in your database or whatever. So you will probably write some code like this: - -```elm -import Json.Decode as Decode exposing (Decoder) - -decodeComment : Decoder Comment -decodeComment = - Decode.map4 Comment - (Decode.field "message" Decode.string) - (Decode.field "upvotes" Decode.int) - (Decode.field "downvotes" Decode.int) - (Decode.field "responses" decodeResponses) - --- PROBLEM -decodeResponses : Decoder Responses -decodeResponses = - Decode.map Responses (Decode.list decodeComment) -``` - -The problem is that now `decodeComment` is defined in terms of itself! To know what `decodeComment` is, I need to expand `decodeResponses`. To know what `decodeResponses` is, I need to expand `decodeComment`. This loop will repeat endlessly! - -In this case, the trick is to use `Json.Decode.lazy` which delays the evaluation of a decoder until it is needed. So the valid definition would look like this: - -```elm -import Json.Decode as Decode exposing (Decoder) - -decodeComment : Decoder Comment -decodeComment = - Decode.map4 Comment - (Decode.field "message" Decode.string) - (Decode.field "upvotes" Decode.int) - (Decode.field "downvotes" Decode.int) - (Decode.field "responses" decodeResponses) - --- SOLUTION -decodeResponses : Decoder Responses -decodeResponses = - Decode.map Responses (Decode.list (Decode.lazy (\_ -> decodeComment))) -``` - -Notice that in `decodeResponses`, we hide `decodeComment` behind an anonymous function. Elm cannot evaluate an anonymous function until it is given arguments, so it allows us to delay evaluation until it is needed. If there are no comments, we will not need to expand it! - -This saves us from expanding the value infinitely. Instead we only expand the value if we need to. - -> **Note:** The same kind of logic can be applied to tasks, random value generators, and parsers. Use `lazy` or `andThen` to make sure a recursive value is only expanded if needed. - - -## Understanding “Bad Recursion” - -The compiler tries to detect bad recursion, but how does it know the difference between good and bad situations? Writing `factorial` is fine, but writing `x = x + 1` is not. One version of `decodeComment` was bad, but the other was fine. What is the rule? - -**Elm will allow recursive definitions as long as there is at least one lambda before you get back to yourself.** So if we write `factorial` without any pretty syntax, it looks like this: - -```elm -factorial = - \n -> if n <= 0 then 1 else n * factorial (n - 1) -``` - -There is technically a lambda between the definition and the use, so it is okay! The same is true with the good version of `decodeComment`. There is a lambda between the definition and the use. As long as there is a lambda before you get back to yourself, the compiler will let it through. - -**This rule is nice, but it does not catch everything.** It is pretty easy to write a definition where the recursion is hidden behind a lambda, but it still immediately expands forever: - -```elm -x = - (\_ -> x) () + 1 -``` - -This follows the rules, but it immediately expands until our program runs out of stack space. It leads to a runtime error as soon as you start your program. It is nice to fail fast, but why not have the compiler detect this as well? It turns out this is much harder than it sounds! - -This is called [the halting problem](https://en.wikipedia.org/wiki/Halting_problem) in computer science. Computational theorists were asking: - -> Can we determine if a program will finish running (i.e. halt) or if it will continue to run forever? - -It turns out that Alan Turing wrote a proof in 1936 showing that (1) in some cases you just have to check by running the program and (2) this check will take forever for programs that do not halt! - -**So we cannot solve the halting problem *in general*, but our simple rule about lambdas can detect the majority of bad cases *in practice*.** diff --git a/hints/comparing-custom-types.md b/hints/comparing-custom-types.md deleted file mode 100644 index e83b5345d3..0000000000 --- a/hints/comparing-custom-types.md +++ /dev/null @@ -1,98 +0,0 @@ -# Comparing Custom Types - -The built-in comparison operators work on a fixed set of types, like `Int` and `String`. That covers a lot of cases, but what happens when you want to compare custom types? - -This page aims to catalog these scenarios and offer alternative paths that can get you unstuck. - - -## Wrapped Types - -It is common to try to get some extra type safety by creating really simple custom types: - -```elm -type Id = Id Int -type Age = Age Int - -type Comment = Comment String -type Description = Description String -``` - -By wrapping the primitive values like this, the type system can now help you make sure that you never mix up a `Id` and an `Age`. Those are different types! This trick is extra cool because it has no runtime cost in `--optimize` mode. The compiler can just use an `Int` or `String` directly when you use that flag! - -The problem arises when you want to use a `Id` as a key in a dictionary. This is a totally reasonable thing to do, but the current version of Elm cannot handle this scenario. - -Instead of creating a `Dict Id Info` type, one thing you can do is create a custom data structure like this: - -```elm -module User exposing (Id, Table, empty, get, add) - -import Dict exposing (Dict) - - --- USER - -type Id = Id Int - - --- TABLE - -type Table info = - Table Int (Dict Int info) - -empty : Table info -empty = - Table 0 Dict.empty - -get : Id -> Table info -> Maybe info -get (Id id) (Table _ dict) = - Dict.get id dict - -add : info -> Table info -> (Table info, Id) -add info (Table nextId dict) = - ( Table (nextId + 1) (Dict.insert nextId info dict) - , Id nextId - ) -``` - -There are a couple nice thing about this approach: - -1. The only way to get a new `User.Id` is to `add` information to a `User.Table`. -2. All the operations on a `User.Table` are explicit. Does it make sense to remove users? To merge two tables together? Are there any special details to consider in those cases? This will always be captured explicitly in the interface of the `User` module. -3. If you ever want to switch the internal representation from `Dict` to `Array` or something else, it is no problem. All the changes will be within the `User` module. - -So while this approach is not as convenient as using a `Dict` directly, it has some benefits of its own that can be helpful in some cases. - - -## Enumerations to Ints - -Say you need to define a `trafficLightToInt` function: - -```elm -type TrafficLight = Green | Yellow | Red - -trafficLightToInt : TrafficLight -> Int -trafficLightToInt trafficLight = - ??? -``` - -We have heard that some people would prefer to use a dictionary for this sort of thing. That way you do not need to write the numbers yourself, they can be generated such that you never have a typo. - -I would recommend using a `case` expression though: - -```elm -type TrafficLight = Green | Yellow | Red - -trafficLightToInt : TrafficLight -> Int -trafficLightToInt trafficLight = - case trafficLight of - Green -> 1 - Yellow -> 2 - Red -> 3 -``` - -This is really straight-forward while avoiding questions like “is `Green` less than or greater than `Red`?” - - -## Something else? - -If you have some other situation, please tell us about it [here](https://github.com/elm/error-message-catalog/issues). That is a log of error messages that can be improved, and we can use the particulars of your scenario to add more advice on this page! diff --git a/hints/comparing-records.md b/hints/comparing-records.md deleted file mode 100644 index eaf46df11c..0000000000 --- a/hints/comparing-records.md +++ /dev/null @@ -1,85 +0,0 @@ -# Comparing Records - -The built-in comparison operators work on a fixed set of types, like `Int` and `String`. That covers a lot of cases, but what happens when you want to compare records? - -This page aims to catalog these scenarios and offer alternative paths that can get you unstuck. - - -## Sorting Records - -Say we want a `view` function that can show a list of students sorted by different characterists. - -We could create something like this: - -```elm -import Html exposing (..) - -type alias Student = - { name : String - , age : Int - , gpa : Float - } - -type Order = Name | Age | GPA - -viewStudents : Order -> List Student -> Html msg -viewStudents order studentns = - let - orderlyStudents = - case order of - Name -> List.sortBy .name students - Age -> List.sortBy .age students - GPA -> List.sortBy .gpa students - in - ul [] (List.map viewStudent orderlyStudents) - -viewStudent : Student -> Html msg -viewStudent student = - li [] [ text student.name ] -``` - -If you are worried about the performance of changing the order or updating information about particular students, you can start using the [`Html.Lazy`](https://package.elm-lang.org/packages/elm/html/latest/Html-Lazy) and [`Html.Keyed`](https://package.elm-lang.org/packages/elm/html/latest/Html-Keyed) modules. The updated code would look something like this: - -```elm -import Html exposing (..) -import Html.Lazy exposing (lazy) -import Html.Keyed as Keyed - -type Order = Name | Age | GPA - -type alias Student = - { name : String - , age : Int - , gpa : Float - } - -viewStudents : Order -> List Student -> Html msg -viewStudents order studentns = - let - orderlyStudents = - case order of - Name -> List.sortBy .name students - Age -> List.sortBy .age students - GPA -> List.sortBy .gpa students - in - Keyed.ul [] (List.map viewKeyedStudent orderlyStudents) - -viewKeyedStudent : Student -> (String, Html msg) -viewKeyedStudent student = - ( student.name, lazy viewStudent student ) - -viewStudent : Student -> Html msg -viewStudent student = - li [] [ text student.name ] -``` - -By using `Keyed.ul` we help the renderer move the DOM nodes around based on their key. This makes it much cheaper to reorder a bunch of students. And by using `lazy` we help the renderer skip a bunch of work. If the `Student` is the same as last time, the render can skip over it. - -> **Note:** Some people are skeptical of having logic like this in `view` functions, but I think the alternative (maintaining sort order in your `Model`) has some serious downsides. Say a colleague is adding a message to `Add` students, but they do not know about the sort order rules needed for presentation. Bug! So in this alternate design, you must diligently test your `update` function to make sure that no message disturbs the sort order. This is bound to lead to bugs over time! -> -> With all the optimizations possible with `Html.Lazy` and `Html.Keyed`, I would always be inclined to work on optimizing my `view` functions rather than making my `update` functions more complicated and error prone. - - -## Something else? - -If you have some other situation, please tell us about it [here](https://github.com/elm/error-message-catalog/issues). That is a log of error messages that can be improved, and we can use the particulars of your scenario to add more advice on this page! diff --git a/hints/implicit-casts.md b/hints/implicit-casts.md deleted file mode 100644 index 14960a8fea..0000000000 --- a/hints/implicit-casts.md +++ /dev/null @@ -1,53 +0,0 @@ - -# Implicit Casts - -Many languages automatically convert from `Int` to `Float` when they think it is necessary. This conversion is often called an [implicit cast](https://en.wikipedia.org/wiki/Type_conversion). - -Languages that will add in implicit casts for addition include: - - - JavaScript - - Python - - Ruby - - C - - C++ - - C# - - Java - - Scala - -These languages generally agree that an `Int` may be implicitly cast to a `Float` when necessary. So everyone is doing it, why not Elm?! - -> **Note:** Ruby does not follow the trend. They implicitly cast a `Float` to an `Int`, truncating all the decimal points! - - -## Type Inference + Implicit Casts - -Elm comes from the ML-family of languages. Languages in the ML-family that **never** do implicit casts include: - - - Standard ML - - OCaml - - Elm - - F# - - Haskell - -Why would so many languages from this lineage require explicit conversions though? - -Well, we have to go back to the 1970s for some background. J. Roger Hindley and Robin Milner independently discovered an algorithm that could _efficiently_ figure out the type of everything in your program without any type annotations. Type Inference! Every ML-family language has some variation of this algorithm at the center of its design. - -For decades, the problem was that nobody could figure out how to combine type inference with implicit casts AND make the resulting algorithm efficient enough for daily use. As far as I know, Scala was the first widely known language to figure out how to combine these two things! Its creator, Martin Odersky did a lot of work on combining type inference and subtyping to make this possible. - -So for any ML-family language designed before Scala, it is safe to assume that implicit conversions just was not an option. Okay, but what about Elm?! It comes after Scala, so why not do it like them?! - - 1. You pay performance cost to mix type inference and implicit conversions. At least as far as anyone knows, it defeats an optimization that is crucial to getting _reliably_ good performance. It is fine in most cases, but it can be a real issue in very large code bases. - - 2. Based on experience reports from Scala users, it seemed like the convenience was not worth the hidden cost. Yes, you can convert `n` in `(n + 1.5)` and everything is nice, but when you are in larger programs that are sparsely annotated, it can be quite difficult to figure out what is going on. - -This user data may be confounded by the fact that Scala allows quite extensive conversions, not just from `Int` to `Float`, but I think it is worth taking seriously nonetheless. So it is _possible_, but it is has tradeoffs. - - -## Conclusion - -First, based on the landscape of design possibilities, it seems like requiring _explicit_ conversions is a pretty nice balance. We can have type inference, it can produce friendly error messages, the algorithm is snappy, and an unintended implicit cast will not flow hundreds of lines before manifesting to the user. - -Second, Elm very much favors explicit code, so this also fits in with the overall spirit of the language and libraries. - -I hope that clarifies why you have to add those `toFloat` and `round` functions! It definitely can take some getting used to, but there are tons of folks who get past that acclimation period and really love the tradeoffs! diff --git a/hints/import-cycles.md b/hints/import-cycles.md deleted file mode 100644 index 841b38bd81..0000000000 --- a/hints/import-cycles.md +++ /dev/null @@ -1,184 +0,0 @@ - -# Import Cycles - -What is an import cycle? In practice you may see it if you create two modules with interrelated `User` and `Comment` types like this: - -```elm -module Comment exposing (..) - -import User - -type alias Comment = - { comment : String - , author : User.User - } -``` - -```elm -module User exposing (..) - -import Comment - -type alias User = - { name : String - , comments : List Comment.Comment - } -``` - -Notice that to compile `Comment` we need to `import User`. And notice that to compile `User` we need to `import Comment`. We need both to compile either! - -Now this is *possible* if the compiler figures out any module cycles and puts them all in one big file to compile them together. That seems fine in our small example, but imagine we have a cycle of 20 modules. If you change *one* of them, you must now recompile *all* of them. In a large code base, this causes extremely long compile times. It is also very hard to disentangle them in practice, so you just end up with slow builds. That is your life now. - -The thing is that you can always write the code *without* cycles by shuffling declarations around, and the resulting code is often much clearer. - - -# How to Break Cycles - -There are quite a few ways to break our `Comment` and `User` cycle from above, so let’s go through four useful strategies. The first one is by far the most common solution! - - -## 1. Combine the Modules - -One approach is to just combine the two modules. If we check out the resulting code, we have actually revealed a problem in how we are representing our data: - -```elm -module BadCombination1 exposing (..) - -type alias Comment = - { comment : String - , author : User - } - -type alias User = - { name : String - , comments : List Comment - } -``` - -Notice that the `Comment` type alias is defined in terms of the `User` type alias and vice versa. Having recursive type aliases like this does not work! That problem is described in depth [here](recursive-alias), but the quick takeaway is that one `type alias` needs to become a `type` to break the recursion. So let’s try again: - -```elm -module BadCombination2 exposing (..) - -type alias Comment = - { comment : String - , author : User - } - -type alias User = - { name : String - , comments : AllUserComments - } - -type AllUserComments = AllUserComments (List Comment) -``` - -Okay, now we have broken the recursion, but we need to ask ourselves, how are we going to actually instantiate these `Comment` and `User` types that we have described. A `Comment` will always have an author, and that `User` will always refer back to the `Comment`. So we seem to want cyclic data here. If we were in JavaScript we might instantiate all the comments in one pass, and then go back through and mutate the users to point to all the relevant comments. In other words, we need *mutation* to create this cyclic data! - -All values are immutable in Elm, so we need to use a more functional strategy. One common approach is to use unique identifiers. Instead of referring directly to “the user object” we can refer to a user ID: - -```elm -module GoodCombination exposing (..) - -import Dict - -type alias Comment = - { comment : String - , author : UserId - } - -type alias UserId = String - -type alias AllComments = - Dict.Dict UserId (List Comment) -``` - -Now in this world, we do not even have cycles in our types anymore! That means we can actually break these out into separate modules again: - -```elm -module Comment exposing (..) - -import Dict -import User - -type alias Comment = - { comment : String - , author : User.Id - } - -type alias AllComments = - Dict.Dict User.Id (List Comment) -``` - -```elm -module User exposing (..) - -type alias Id = String -``` - -So now we are back to the two modules we wanted, but we have data structures that are going to work much better in a functional language like Elm! **This is the common approach, and it is what you hope will happen!** - - -## 2. Make a New Module - -Now say there are actually a ton of functions and values in the `Comment` and `User` modules. Combining them into one does not seem like a good strategy. Instead you can create a *third* module that just has the shared types and functions. Let’s pretend we call that third module `GoodCombination`. So rather than having `Comment` and `User` depend on each other, they now both depend on `GoodCombination`. We broke our cycle! - -**This strategy is less common.** You generally want to keep the core `type` of a module with all the functions that act upon it directly, so separating a `type` from everything else is a bad sign. So maybe there is a `User` module that contains a bunch of helper functions, but you *use* all those helper functions in a bunch of other modules that interact with users in various ways. In that scenario, it is still more sophisticated than “just throw the types in a module together” and hope it turns out alright. - - -## 3. Use Type Variables - -Another way to avoid module cycles is to be more generic in how you represent your data: - -```elm -module Comment exposing (..) - -type alias Comment author = - { comment : String - , author : author - } -``` - -```elm -module User exposing (..) - -type alias User comment = - { name : String - , comments : List comment - } -``` - -Notice that `Comment` and `User` no longer need to import each other! Instead, whenever we use these modules, we need to fill in the type variable. So we may import both `Comment` and `User` and try to combine them into a `Comment (User (Comment (User ...)))`. Gah, we ran into the recursive type alias thing again! - -So this strategy fails pretty badly with our particular example. The code is more complicated and it still does not work! So **this strategy is rarely useful**, but when it works, it can simplify things quite a lot. - - -## 4. Hiding Implementation Details in Packages - -This gets a little bit trickier when you are creating a package like `elm-lang/parser` which is built around the `Parser` type. - -That package has a couple exposed modules: `Parser`, `Parser.LanguageKit`, and `Parser.LowLevel`. All of these modules want access to the internal details of the `Parser` type, but we do not want to ever expose those internal details to the *users* of this package. So where should the `Parser` type live?! - -Usually you know which module should expose the type for the best public API. In this case, it makes sense for it to live in the `Parser` module. The way to manage this is to create a `Parser.Internal` module with a definition like: - -```elm -module Parser.Internal exposing (..) - -type Parser a = - Parser ... -``` - -Now we can `import Parser.Internal` and use it in any of the modules in our package. The trick is that we never expose the `Parser.Internal` module to the *users* of our package. We can see what is inside, but they cannot! Then in the `Parser` module we can say: - -```elm -module Parser exposing (..) - -import Parser.Internal as Internal - -type alias Parser a = - Internal.Parser a -``` - -So now folks see a `Parser` type exposed by the `Parser` module, and it is the one that is used throughout all the modules in the package. Do not screw up your data representation to avoid this trick! I think we can improve how this appears in documentation, but overall this is the best way to go. - -Now again, this strategy is particularly useful in packages. It is not as worthwhile in application code. diff --git a/hints/imports.md b/hints/imports.md deleted file mode 100644 index 813937af98..0000000000 --- a/hints/imports.md +++ /dev/null @@ -1,126 +0,0 @@ - -# Hints for Imports - -When getting started with Elm, it is pretty common to have questions about how the `import` declarations work exactly. These questions usually arise when you start playing with the `Html` library so we will focus on that. - - -
- -## `import` - -An Elm file is called a **module**. To access code in other files, you need to `import` it! - -So say you want to use the [`div`](http://package.elm-lang.org/packages/elm-lang/html/latest/Html#div) function from the [`elm-lang/html`](http://package.elm-lang.org/packages/elm-lang/html/latest) package. The simplest way is to import it like this: - -```elm -import Html - -main = - Html.div [] [] -``` - -After saying `import Html` we can refer to anything inside that module as long as it is *qualified*. This works for: - - - **Values** — we can refer to `Html.text`, `Html.h1`, etc. - - **Types** — We can refer to [`Attribute`](http://package.elm-lang.org/packages/elm-lang/html/latest/Html#Attribute) as `Html.Attribute`. - -So if we add a type annotation to `main` it would look like this: - -```elm -import Html - -main : Html.Html msg -main = - Html.div [] [] -``` - -We are referring to the [`Html`](http://package.elm-lang.org/packages/elm-lang/html/latest/Html#Html) type, using its *qualified* name `Html.Html`. This can feel weird at first, but it starts feeling natural quite quickly! - -> **Note:** Modules do not contain other modules. So the `Html` module *does not* contain the `Html.Attributes` module. Those are separate names that happen to have some overlap. So if you say `import Html` you *do not* get access to `Html.Attributes.style`. You must `import Html.Attributes` module separately. - - -
- -## `as` - -It is best practice to always use *qualified* names, but sometimes module names are so long that it becomes unwieldy. This is common for the `Html.Attributes` module. We can use the `as` keyword to help with this: - -```elm -import Html -import Html.Attributes as A - -main = - Html.div [ A.style "color" "red" ] [ Html.text "Hello!" ] -``` - -Saying `import Html.Attributes as A` lets us refer to any value or type in `Html.Attributes` as long as it is qualified with an `A`. So now we can refer to [`style`](http://package.elm-lang.org/packages/elm-lang/html/latest/Html-Attributes#style) as `A.style`. - - -
- -## `exposing` - -In quick drafts, maybe you want to use *unqualified* names. You can do that with the `exposing` keyword like this: - -```elm -import Html exposing (..) -import Html.Attributes exposing (style) - -main : Html msg -main = - div [ style "color" "red" ] [ text "Hello!" ] -``` - -Saying `import Html exposing (..)` means I can refer to any value or type from the `Html` module without qualification. Notice that I use the `Html` type, the `div` function, and the `text` function without qualification in the example above. - -> **Note:** It seems neat to expose types and values directly, but it can get out of hand. Say you `import` ten modules `exposing` all of their content. It quickly becomes difficult to figure out what is going on in your code. “Wait, where is this function from?” And then trying to sort through all the imports to find it. Point is, use `exposing (..)` sparingly! - -Saying `import Html.Attributes exposing (style)` is a bit more reasonable. It means I can refer to the `style` function without qualification, but that is it. You are still importing the `Html.Attributes` module like normal though, so you would say `Html.Attributes.class` or `Html.Attributes.id` to refer to other values and types from that module. - - -
- -## `as` and `exposing` - -There is one last way to import a module. You can combine `as` and `exposing` to try to get a nice balance of qualified names: - -```elm -import Html exposing (Html, div, text) -import Html.Attributes as A exposing (style) - -main : Html msg -main = - div [ A.class "greeting", style "color" "red" ] [ text "Hello!" ] -``` - -Notice that I refer to `A.class` which is qualified and `style` which is unqualified. - - -
- -## Default Imports - -We just learned all the variations of the `import` syntax in Elm. You will use some version of that syntax to `import` any module you ever write. - -It would be the best policy to make it so every module in the whole ecosystem works this way. We thought so in the past at least, but there are some modules that are so commonly used that the Elm compiler automatically adds the imports to every file. These default imports include: - -```elm -import Basics exposing (..) -import List exposing (List, (::)) -import Maybe exposing (Maybe(..)) -import Result exposing (Result(..)) -import String -import Tuple - -import Debug - -import Platform exposing (Program) -import Platform.Cmd as Cmd exposing (Cmd) -import Platform.Sub as Sub exposing (Sub) -``` - -You can think of these imports being at the top of any module you write. - -One could argue that `Maybe` is so fundamental to how we handle errors in Elm code that it is *basically* part of the language. One could also argue that it is extraordinarily annoying to have to import `Maybe` once you get past your first couple weeks with Elm. Either way, we know that default imports are not ideal in some sense, so we have tried to keep the default imports as minimal as possible. - -> **Note:** Elm performs dead code elimination, so if you do not use something from a module, it is not included in the generated code. So if you `import` a module with hundreds of functions, you do not need to worry about the size of your assets. You will only get what you use! diff --git a/hints/infinite-type.md b/hints/infinite-type.md deleted file mode 100644 index c16584d954..0000000000 --- a/hints/infinite-type.md +++ /dev/null @@ -1,42 +0,0 @@ - -# Hints for Infinite Types - -Infinite types are probably the trickiest kind of bugs to track down. **Writing down type annotations is usually the fastest way to figure them out.** Let's work through an example to get a feel for how these errors usually work though! - - -## Example - -A common way to get an infinite type error is very small typos. For example, do you see the problem in the following code? - -```elm -incrementNumbers list = - List.map incrementNumbers list - -incrementNumber n = - n + 1 -``` - -The issue is that `incrementNumbers` calls itself, not the `incrementNumber` function defined below. So there is an extra `s` in this program! Let's focus on that: - -```elm -incrementNumbers list = - List.map incrementNumbers list -- BUG extra `s` makes this self-recursive -``` - -Now the compiler does not know that anything is wrong yet. It just tries to figure out the types like normal. It knows that `incrementNumbers` is a function. The definition uses `List.map` so we can deduce that `list : List t1` and the result of this function call should be some other `List t2`. This also means that `incrementNumbers : List t1 -> List t2`. - -The issue is that `List.map` uses `incrementNumbers` on `list`! That means that each element of `list` (which has type `t1`) must be fed into `incrementNumbers` (which takes `List t1`) - -That means that `t1 = List t1`, which is an infinite type! If we start expanding this, we get `List (List (List (List (List ...))))` out to infinity! - -The point is mainly that we are in a confusing situation. The types are confusing. This explanation is confusing. The compiler is confused. It is a bad time. But luckily, the more type annotations you add, the better chance there is that you and the compiler can figure things out! So say we change our definition to: - -```elm -incrementNumbers : List Int -> List Int -incrementNumbers list = - List.map incrementNumbers list -- STILL HAS BUG -``` - -Now we are going to get a pretty normal type error. Hey, you said that each element in the `list` is an `Int` but I cannot feed that into a `List Int -> List Int` function! Something like that. - -In summary, the root issue is often some small typo, and the best way out is to start adding type annotations on everything! diff --git a/hints/init.md b/hints/init.md deleted file mode 100644 index 1ee7f3750b..0000000000 --- a/hints/init.md +++ /dev/null @@ -1,55 +0,0 @@ - -# Creating an Elm project - -The main goal of `elm init` is to get you to this page! - -It just creates an `elm.json` file and a `src/` directory for your code. - - -## What is `elm.json`? - -This file describes your project. It lists all of the packages you depend upon, so it will say the particular version of [`elm/core`](https://package.elm-lang.org/packages/elm/core/latest/) and [`elm/html`](https://package.elm-lang.org/packages/elm/html/latest/) that you are using. It makes builds reproducible! You can read a bit more about it [here](https://github.com/elm/compiler/blob/master/docs/elm.json/application.md). - -You should generally not edit it by hand. It is better to add new dependencies with commands like `elm install elm/http` or `elm install elm/json`. - - -## What goes in `src/`? - -This is where all of your Elm files live. It is best to start with a file called `src/Main.elm`. As you work through [the official guide](https://guide.elm-lang.org/), you can put the code examples in that `src/Main.elm` file. - - -## How do I compile it? - -Run `elm reactor` in your project. Now you can go to [`http://localhost:8000`](http://localhost:8000) and browse through all the files in your project. If you navigate to `.elm` files, it will compile them for you! - -If you want to do things more manually, you can run `elm make src/Main.elm` and it will produce an `index.html` file that you can look at in your browser. - - -## How do I structure my directories? - -Many folks get anxious about their project structure. “If I get it wrong, I am doomed!” This anxiety makes sense in languages where refactoring is risky, but Elm is not one of those languages! - -So we recommend that newcomers staying in one file until you get into the 600 to 1000 range. Push out of your comfort zone. Having the experience of being fine in large files will help you understand the boundaries in Elm, rather than just defaulting to the boundaries you learned in another language. - -The talk [The Life of a File](https://youtu.be/XpDsk374LDE) gets into this a lot more. The advice about building modules around a specific [custom type](https://guide.elm-lang.org/types/custom_types.html) is particularly important! You will see that emphasized a lot as you work through the official guide. - - -## How do I write tests? - -Elm will catch a bunch of errors statically, and I think it is worth skipping tests at first to get a feeling for when tests will actually help you _in Elm_. - -From there, we have a great testing package called [`elm-explorations/test`](https://github.com/elm-explorations/test) that can help you out! It is particularly helpful for teams working on a large codebase. When you are editing code you have never seen before, tests can capture additional details and constraints that are not otherwise apparent! - - -## How do I start fancier projects? - -I wanted `elm init` to generate as little code as possible. It is mainly meant to get you to this page! If you would like a more elaborate starting point, I recommend starting projects with commands like these: - -```bash -git clone https://github.com/evancz/elm-todomvc.git -git clone https://github.com/rtfeldman/elm-spa-example.git -``` - -The idea is that Elm projects should be so simple that nobody needs a tool to generate a bunch of stuff. This also captures the fact that project structure _should_ evolve organically as your application develops, never ending up exactly the same as other projects. - -But if you have something particular you want, I recommend creating your own starter recipe and using `git clone` when you start new projects. That way (1) you can get exactly what you want and (2) we do not end up with a complex `elm init` that ends up being confusing for beginners! diff --git a/hints/missing-patterns.md b/hints/missing-patterns.md deleted file mode 100644 index ae47999860..0000000000 --- a/hints/missing-patterns.md +++ /dev/null @@ -1,139 +0,0 @@ - -# Hints for Missing Patterns - -Elm checks to make sure that all possible inputs to a function or `case` are handled. This gives us the guarantee that no Elm code is ever going to crash because data had an unexpected shape. - -There are a couple techniques for making this work for you in every scenario. - - -## The danger of wildcard patterns - -A common scenario is that you want to add a tag to a custom type that is used in a bunch of places. For example, maybe you are working different variations of users in a chat room: - -```elm -type User - = Regular String Int - | Anonymous - -toName : User -> String -toName user = - case user of - Regular name _ -> - name - - _ -> - "anonymous" -``` - -Notice the wildcard pattern in `toName`. This will hurt us! Say we add a `Visitor String` variant to `User` at some point. Now we have a bug that visitor names are reported as `"anonymous"`, and the compiler cannot help us! - -So instead, it is better to explicitly list all possible variants, like this: - -```elm -type User - = Regular String Int - | Visitor String - | Anonymous - -toName : User -> String -toName user = - case user of - Regular name _ -> - name - - Anonymous -> - "anonymous" -``` - -Now the compiler will say "hey, what should `toName` do when it sees a `Visitor`?" This is a tiny bit of extra work, but it is very worth it! - - -## I want to go fast! - -Imagine that the `User` type appears in 20 or 30 functions across your project. When we add a `Visitor` variant, the compiler points out all the places that need to be updated. That is very convenient, but in a big project, maybe you want to get through it extra quickly. - -In that case, it can be helpful to use [`Debug.todo`](https://package.elm-lang.org/packages/elm-lang/core/latest/Debug#todo) to leave some code incomplete: - -```elm -type User - = Regular String Int - | Visitor String - | Anonymous - -toName : User -> String -toName user = - case user of - Regular name _ -> - name - - Visitor _ -> - Debug.todo "give the visitor name" - - Anonymous -> - "anonymous" - --- and maybe a bunch of other things -``` - -In this case it is easier to just write the implementation, but the point is that on more complex functions, you can put things off a bit. - -The Elm compiler is actually aware of `Debug.todo` so when it sees it in a `case` like this, it will crash with a bunch of helpful information. It will tell you: - - 1. The name of the module that contains the code. - 2. The line numbers of the `case` containing the TODO. - 3. The particular value that led to this TODO. - -From that information you have a pretty good idea of what went wrong and can go fix it. - -I tend to use `Debug.todo` as the message when my goal is to go quick because it makes it easy to go and find all remaining todos in my code before a release. - - -## A list that definitely is not empty - -This can come up from time to time, but Elm **will not** let you write code like this: - -```elm -last : List a -> a -last list = - case list of - [x] -> - x - - _ :: rest -> - last rest -``` - -This is no good. It does not handle the empty list. There are two ways to handle this. One is to make the function return a `Maybe` like this: - -```elm -last : List a -> Maybe a -last list = - case list of - [] -> - Nothing - - [x] -> - Just x - - _ :: rest -> - last rest -``` - -This is nice because it lets users know that there might be a failure, so they can recover from it however they want. - -The other option is to “unroll the list” one level to ensure that no one can ever provide an empty list in the first place: - -```elm -last : a -> List a -> a -last first rest = - case rest of - [] -> - first - - newFirst :: newRest -> - last newFirst newRest -``` - -By demanding the first element of the list as an argument, it becomes impossible to call this function if you have an empty list! - -This “unroll the list” trick is quite useful. I recommend using it directly, not through some external library. It is nothing special. Just a useful idea! diff --git a/hints/optimize.md b/hints/optimize.md deleted file mode 100644 index 92c714b778..0000000000 --- a/hints/optimize.md +++ /dev/null @@ -1,59 +0,0 @@ - -# How to optimize Elm code - -When you are serving a website, there are two kinds of optimizations you want to do: - -1. **Asset Size** — How can we send as few bits as possible? -2. **Performance** — How can those bits run as quickly as possible? - -It turns out that Elm does really well on both! We have [very small assets](https://elm-lang.org/news/small-assets-without-the-headache) and [very fast code](https://elm-lang.org/news/blazing-fast-html-round-two) when compared to the popular alternatives. - -Okay, but how do we get those numbers? - - -## Instructions - -Step one is to compile with the `--optimize` flag. This does things like shortening record field names and unboxing values. - -Step two is to call `uglifyjs` with a bunch of special flags. The flags unlock optimizations that are unreliable in normal JS code, but because Elm does not have side-effects, they work fine for us! - -Putting those together, here is how I would optimize `src/Main.elm` with two terminal commands: - -```bash -elm make src/Main.elm --optimize --output=elm.js -uglifyjs elm.js --compress "pure_funcs=[F2,F3,F4,F5,F6,F7,F8,F9,A2,A3,A4,A5,A6,A7,A8,A9],pure_getters,keep_fargs=false,unsafe_comps,unsafe" | uglifyjs --mangle --output=elm.min.js -``` - -After this you will have an `elm.js` and a significantly smaller `elm.min.js` file! - -**Note 1:** `uglifyjs` is called twice there. First to `--compress` and second to `--mangle`. This is necessary! Otherwise `uglifyjs` will ignore our `pure_funcs` flag. - -**Note 2:** If the `uglifyjs` command is not available in your terminal, you can run the command `npm install uglify-js --global` to download it. You probably already have `npm` from getting `elm repl` working, but if not, it is bundled with [nodejs](https://nodejs.org/). - -## Scripts - -It is hard to remember all that, so it is probably a good idea to write a script that does it. - -I would maybe want to run `./optimize.sh src/Main.elm` and get out `elm.js` and `elm.min.js`, so on Mac or Linux, I would make a script called `optimize.sh` like this: - -```bash -#!/bin/sh - -set -e - -js="elm.js" -min="elm.min.js" - -elm make --optimize --output=$js $@ - -uglifyjs $js --compress "pure_funcs=[F2,F3,F4,F5,F6,F7,F8,F9,A2,A3,A4,A5,A6,A7,A8,A9],pure_getters,keep_fargs=false,unsafe_comps,unsafe" | uglifyjs --mangle --output=$min - -echo "Initial size: $(cat $js | wc -c) bytes ($js)" -echo "Minified size:$(cat $min | wc -c) bytes ($min)" -echo "Gzipped size: $(cat $min | gzip -c | wc -c) bytes" -``` - -It also prints out all the asset sizes for you! Your server should be configured to gzip the assets it sends, so the last line is telling you how many bytes would _actually_ get sent to the user. - -Again, the important commands are `elm` and `uglifyjs` which work on any platform, so it should not be too tough to do something similar on Windows. - diff --git a/hints/port-modules.md b/hints/port-modules.md deleted file mode 100644 index bf44a25673..0000000000 --- a/hints/port-modules.md +++ /dev/null @@ -1,32 +0,0 @@ - -# No Ports in Packages - -The package ecosystem is one of the most important parts of Elm. Right now, our ecosystem has some compelling benefits: - - - There are many obvious default packages that work well. - - Adding dependencies cannot introduce runtime exceptions. - - Patch changes cannot lead to surprise build failures. - -These are really important factors if you want to *quickly* create *reliable* applications. The Elm community thinks this is valuable. - -Other communities think that the *number* of packages is a better measure of ecosystem health. That is a fine metric to use, but it is not the one we use for Elm. We would rather have 50 great packages than 100k packages of wildly varying quality. - - -## So what about ports? - -Imagine you install a new package that claims to support `localStorage`. You get it set up, working through any compile errors. You run it, but it does not seem to work! After trying to figure it out for hours, you realize there is some poorly documented `port` to hook up... - -Okay, now you need to hook up some JavaScript code. Is that JS file in the Elm package? Or is it on `npm`? Wait, what version on `npm` though? And is this patch version going to work as well? Also, how does this file fit into my build process? And assuming we get through all that, maybe the `port` has the same name as one of the ports in your project. Or it clashes with a `port` name in another package. - -**Suddenly adding dependencies is much more complicated and risky!** An experienced developer would always check for ports up front, spending a bunch of time manually classifying unacceptable packages. Most people would not know to do that and learn all the pitfalls through personal experience, ultimately spending even *more* time than the person who defensively checks to avoid these issues. - -So “ports in packages” would impose an enormous cost on application developers, and in the end, we would have a less reliable package ecosystem overall. - - -## Conclusion - -Our wager with the Elm package ecosystem is that it is better to get a package *right* than to get it *right now*. So while we could use “ports in packages” as a way to get twenty `localStorage` packages of varying quality *right now*, we are choosing not to go that route. Instead we ask that developers use ports directly in their application code, getting the same result a different way. - -Now this may not be the right choice for your particular project, and that is okay! We will be expanding our core libraries over time, as explained [here](https://github.com/elm-lang/projects/blob/master/roadmap.md#where-is-the-localstorage-package), and we hope you will circle back later to see if Elm has grown into a better fit! - -If you have more questions about this choice or what it means for your application, please come ask in [the Elm slack](http://elmlang.herokuapp.com/). Folks are friendly and happy to help out! Chances are that a `port` in your application will work great for your case once you learn more about how they are meant to be used. diff --git a/hints/recursive-alias.md b/hints/recursive-alias.md deleted file mode 100644 index 254c0724de..0000000000 --- a/hints/recursive-alias.md +++ /dev/null @@ -1,162 +0,0 @@ - -# Hints for Recursive Type Aliases - -At the root of this issue is the distinction between a `type` and a `type alias`. - - -## What is a type alias? - -When you create a type alias, you are just creating a shorthand to refer to an existing type. So when you say the following: - -```elm -type alias Time = Float - -type alias Degree = Float - -type alias Weight = Float -``` - -You have not created any *new* types, you just made some alternate names for `Float`. You can write down things like this and it'll work fine: - -```elm -add : Time -> Degree -> Weight -add time degree = - time + degree -``` - -This is kind of a weird way to use type aliases though. The typical usage would be for records, where you do not want to write out the whole thing every time. Stuff like this: - -```elm -type alias Person = - { name : String - , age : Int - , height : Float - } -``` - -It is much easier to write down `Person` in a type, and then it will just expand out to the underlying type when the compiler checks the program. - - -## Recursive type aliases? - -Okay, so lets say you have some type that may contain itself. In Elm, a common example of this is a comment that might have subcomments: - -```elm -type alias Comment = - { message : String - , upvotes : Int - , downvotes : Int - , responses : List Comment - } -``` - -Now remember that type *aliases* are just alternate names for the real type. So to make `Comment` into a concrete type, the compiler would start expanding it out. - -```elm - { message : String - , upvotes : Int - , downvotes : Int - , responses : - List - { message : String - , upvotes : Int - , downvotes : Int - , responses : - List - { message : String - , upvotes : Int - , downvotes : Int - , responses : List ... - } - } - } -``` - -The compiler cannot deal with values like this. It would just keep expanding forever. - - -## Recursive types! - -In cases where you want a recursive type, you need to actually create a brand new type. This is what the `type` keyword is for. A simple example of this can be seen when defining a linked list: - -```elm -type List - = Empty - | Node Int List -``` - -No matter what, the type of `Node n xs` is going to be `List`. There is no expansion to be done. This means you can represent recursive structures with types that do not explode into infinity. - -So let's return to wanting to represent a `Comment` that may have responses. There are a couple ways to do this: - - -### Obvious, but kind of annoying - -```elm -type Comment = - Comment - { message : String - , upvotes : Int - , downvotes : Int - , responses : List Comment - } -``` - -Now lets say you want to register an upvote on a comment: - -```elm -upvote : Comment -> Comment -upvote (Comment comment) = - Comment { comment | upvotes = 1 + comment.upvotes } -``` - -It is kind of annoying that we now have to unwrap and wrap the record to do anything with it. - - -### Less obvious, but nicer - -```elm -type alias Comment = - { message : String - , upvotes : Int - , downvotes : Int - , responses : Responses - } - -type Responses = Responses (List Comment) -``` - -In this world, we introduce the `Responses` type to capture the recursion, but `Comment` is still an alias for a record. This means the `upvote` function looks nice again: - -```elm -upvote : Comment -> Comment -upvote comment = - { comment | upvotes = 1 + comment.upvotes } -``` - -So rather than having to unwrap a `Comment` to do *anything* to it, you only have to do some unwrapping in the cases where you are doing something recursive. In practice, this means you will do less unwrapping which is nice. - - -## Mutually recursive type aliases - -It is also possible to build type aliases that are *mutually* recursive. That might be something like this: - -```elm -type alias Comment = - { message : String - , upvotes : Int - , downvotes : Int - , responses : Responses - } - -type alias Responses = - { sortBy : SortBy - , responses : List Comment - } - -type SortBy = Time | Score | MostResponses -``` - -When you try to expand `Comment` you have to expand `Responses` which needs to expand `Comment` which needs to expand `Responses`, etc. - -So this is just a fancy case of a self-recursive type alias. The solution is the same. Somewhere in that cycle, you need to define an actual `type` to end the infinite expansion. diff --git a/hints/repl.md b/hints/repl.md deleted file mode 100644 index 343b878446..0000000000 --- a/hints/repl.md +++ /dev/null @@ -1,73 +0,0 @@ - -# REPL - -The REPL lets you interact with Elm values and functions in your terminal. - - -## Use - -You can type in expressions, definitions, custom types, and module imports using normal Elm syntax. - -```elm -> 1 + 1 -2 : number - -> "hello" ++ "world" -"helloworld" : String -``` - -The same can be done with definitions and custom types: - -```elm -> fortyTwo = 42 -42 : number - -> increment n = n + 1 - : number -> number - -> increment 41 -42 : number - -> factorial n = -| if n < 1 then -| 1 -| else -| n * factorial (n-1) -| - : number -> number - -> factorial 5 -120 : number - -> type User -| = Regular String -| | Visitor String -| - -> case Regular "Tom" of -| Regular name -> "Hey again!" -| Visitor name -> "Nice to meet you!" -| -"Hey again!" : String -``` - -When you run `elm repl` in a project with an [`elm.json`](https://github.com/elm/compiler/blob/master/docs/elm.json/application.md) file, you can import any module available in the project. So if your project has an `elm/html` dependency, you could say: - -```elm -> import Html exposing (Html) - -> Html.text "hello" - : Html msg - -> Html.text - : String -> Html msg -``` - -If you create a module in your project named `MyThing` in your project, you can say `import MyThing` in the REPL as well. Any module that is accessible in your project should be accessible in the REPL. - - -## Exit - -To exit the REPL, you can type `:exit`. - -You can also press `ctrl-d` or `ctrl-c` on some platforms. diff --git a/hints/shadowing.md b/hints/shadowing.md deleted file mode 100644 index b5d7b5fd9e..0000000000 --- a/hints/shadowing.md +++ /dev/null @@ -1,70 +0,0 @@ - -# Variable Shadowing - -Variable shadowing is when you define the same variable name twice in an ambiguous way. Here is a pretty reasonable use of shadowing: - -```elm -viewName : Maybe String -> Html msg -viewName name = - case name of - Nothing -> - ... - - Just name -> - ... -``` - -I define a `name` with type `Maybe String` and then in that second branch, I define a `name` that is a `String`. Now that there are two `name` values, it is not 100% obvious which one you want in that second branch. - -Most linters produce warnings on variable shadowing, so Elm makes “best practices” the default. Just rename the first one to `maybeName` and move on. - -This choice is relatively uncommon in programming languages though, so I want to provide the reasoning behind it. - - -## The Cost of Shadowing - -The code snippet from above is the best case scenario for variable shadowing. It is pretty clear really. But that is because it is a fake example. It does not even compile. - -In a large module that is evolving over time, this is going to cause bugs in a very predictable way. You will have two definitions, separated by hundreds of lines. For example: - -```elm -name : String -name = - "Tom" - --- hundreds of lines - -viewName : String -> Html msg -viewName name = - ... name ... name ... name ... -``` - -Okay, so the `viewName` function has an argument `name` and it uses it three times. Maybe the `viewName` function is 50 lines long in total, so those uses are not totally easy to see. This is fine so far, but say your colleague comes along five months later and wants to support first and last names. They refactor the code like this: - -```elm -viewName : String -> String -> Html msg -viewName firstName lastName = - ... name ... name ... name ... -``` - -The code compiles, but it does not work as intended. They forgot to change all the uses of `name`, and because it shadows the top-level `name` value, it always shows up as `"Tom"`. It is a simple mistake, but it is always the last thing I think of. - -> Is the data being fetched properly? Let me log all of the JSON requests. Maybe the JSON decoders are messed up? Hmm. Maybe someone is transforming the name in a bad way at some point? Let me check my `update` code. - -Basically, a bunch of time gets wasted on something that could easily be detected by the compiler. But this bug is rare, right? - - -## Aggregate Cost - -Thinking of a unique and helpful name takes some extra time. Maybe 30 seconds. But it means that: - - 1. Your code is easier to read and understand later on. So you spend 30 seconds once `O(1)` rather than spending 10 seconds each time someone reads that code in the future `O(n)`. - - 2. The tricky shadowing bug described above is impossible. Say there is a 5% chance that any given edit produces a shadowing bug, and that resolving that shadowing bug takes one hour. That means the expected time for each edit increases by three minutes. - -If you are still skeptical, I encourage you can play around with the number of edits, time costs, and probabilities here. When shadowing is not allowed, the resulting overhead for the entire lifetime of the code is the 30 seconds it takes to pick a better name, so that is what you need to beat! - - -## Summary - -Without shadowing, the code easier to read and folks spend less time on pointless debugging. The net outcome is that folks have more time to make something wonderful with Elm! diff --git a/hints/tuples.md b/hints/tuples.md deleted file mode 100644 index fd349d0b49..0000000000 --- a/hints/tuples.md +++ /dev/null @@ -1,19 +0,0 @@ - -# From Tuples to Records - -The largest tuple possible in Elm has three entries. Once you get to four, it is best to make a record with named entries. - -For example, it is _conceivable_ to represent a rectangle as four numbers like `(10,10,100,100)` but it would be more self-documenting to use a record like this: - -```elm -type alias Rectangle = - { x : Float - , y : Float - , width : Float - , height : Float - } -``` - -Now it is clear that the dimensions should be `Float` values. It is also clear that we are not using the convention of specifying the top-left and bottom-right corners. It could be clearer about whether the `x` and `y` is the point in the top-left or in the middle though! - -Anyway, using records like this also gives you access to syntax like `rect.x`, `.x`, and `{ rect | x = 40 }`. It is not clear how to design features like that for arbitrarily sized tuples, so we did not. We already have a way, and it is more self-documenting! diff --git a/hints/type-annotations.md b/hints/type-annotations.md deleted file mode 100644 index ce25034081..0000000000 --- a/hints/type-annotations.md +++ /dev/null @@ -1,62 +0,0 @@ - -# Hints for Type Annotation Problems - -At the root of this kind of issue is always the fact that a type annotation in your code does not match the corresponding definition. Now that may mean that the type annotation is "wrong" or it may mean that the definition is "wrong". The compiler cannot figure out your intent, only that there is some mismatch. - -This document is going to outline the various things that can go wrong and show some examples. - - -## Annotation vs. Definition - -The most common issue is with user-defined type variables that are too general. So lets say you have defined a function like this: - -```elm -addPair : (a, a) -> a -addPair (x, y) = - x + y -``` - -The issue is that the type annotation is saying "I will accept a tuple containing literally *anything*" but the definition is using `(+)` which requires things to be numbers. So the compiler is going to infer that the true type of the definition is this: - -```elm -addPair : (number, number) -> number -``` - -So you will probably see an error saying "I cannot match `a` with `number`" which is essentially saying, you are trying to provide a type annotation that is **too general**. You are saying `addPair` accepts anything, but in fact, it can only handle numbers. - -In cases like this, you want to go with whatever the compiler inferred. It is good at figuring this kind of stuff out ;) - - -## Annotation vs. Itself - -It is also possible to have a type annotation that clashes with itself. This is probably more rare, but someone will run into it eventually. Let's use another version of `addPair` with problems: - -```elm -addPair : (Int, Int) -> number -addPair (x, y) = - x + y -``` - -In this case the annotation says we should get a `number` out, but because we were specific about the inputs being `Int`, the output should also be an `Int`. - - -## Annotation vs. Internal Annotation - -A quite tricky case is when an outer type annotation clashes with an inner type annotation. Here is an example of this: - -```elm -filter : (a -> Bool) -> List a -> List a -filter isOkay list = - let - keepIfOkay : a -> Maybe a - keepIfOkay x = - if isOkay x then Just x else Nothing - in - List.filterMap keepIfOkay list -``` - -This case is very unfortunate because all the type annotations are correct, but there is a detail of how type inference works right now that **user-defined type variables are not shared between annotations**. This can lead to probably the worst type error messages we have because the problem here is that `a` in the outer annotation does not equal `a` in the inner annotation. - -For now the best route is to leave off the inner annotation. It is unfortunate, and hopefully we will be able to do a nicer thing in future releases. - -""" diff --git a/installers/README.md b/installers/README.md deleted file mode 100644 index 8a6c2fedd2..0000000000 --- a/installers/README.md +++ /dev/null @@ -1,30 +0,0 @@ -# Installing Elm - -The normal path is to work through [the guide](https://guide.elm-lang.org/) until you need to install, but you can skip to installation directly by going [here](https://guide.elm-lang.org/install/terminal.html). - - -
- -## Installing Multiple Versions - -The secret is that Elm is just a single executable file. If you are developing a project in `~/Desktop/project/` you can download this file into that directory and run commands like `~/Desktop/project/elm make src/Main.elm` or `./elm make src/Main.elm`. You just run the local copy of the executable file! - -The instructions for [Mac][mac] and [Linux][lin] explain how to do this in more detail. You can follow the same steps on Windows, but you need to do each step by hand. (E.g. download the file through your browser rather than with a terminal command.) - - -
- -## Installing Previous Versions - -The past binaries for Mac, Linux, and Windows are hosted [here](https://github.com/elm/compiler/releases). - -You can download the executable files directly and use them locally. - - -
- -## Uninstall - -- [Mac](https://github.com/elm/compiler/blob/master/installers/mac/README.md#uninstall) -- [Linux](https://github.com/elm/compiler/blob/master/installers/linux/README.md#uninstall) -- [Windows](https://github.com/elm/compiler/blob/master/installers/win/README.md#uninstall) diff --git a/installers/linux/Dockerfile b/installers/linux/Dockerfile deleted file mode 100644 index d0e58b10cf..0000000000 --- a/installers/linux/Dockerfile +++ /dev/null @@ -1,25 +0,0 @@ -# Create: https://gist.github.com/rlefevre/1523f47e75310e28eee243c9c5651ac9 -# Delete: docker system prune -a ; docker images -a - -FROM alpine:3.10 - -# branch -ARG branch=master -# commit or tag -ARG commit=HEAD - -# Install required packages -RUN apk add --update ghc cabal git musl-dev zlib-dev ncurses-dev ncurses-static wget - -# Checkout elm compiler -WORKDIR /tmp -RUN git clone -b $branch https://github.com/elm/compiler.git - -# Build a statically linked elm binary -WORKDIR /tmp/compiler -RUN git checkout $commit -RUN rm worker/elm.cabal -RUN cabal new-update -RUN cabal new-configure --disable-executable-dynamic --ghc-option=-optl=-static --ghc-option=-optl=-pthread -RUN cabal new-build -RUN strip -s ./dist-newstyle/build/x86_64-linux/ghc-8.4.3/elm-0.19.1/x/elm/build/elm/elm diff --git a/installers/linux/README.md b/installers/linux/README.md deleted file mode 100644 index 0909ac54c9..0000000000 --- a/installers/linux/README.md +++ /dev/null @@ -1,93 +0,0 @@ -# Install Instructions - -The pre-compiled binary for Linux works on a very wide range of distributions. - -It should be possible to install it by running the following commands in your terminal: - -```bash -# Move to your Desktop so you can see what is going on easier. -# -cd ~/Desktop/ - -# Download the 0.19.0 binary for Linux. -# -# +-----------+----------------------+ -# | FLAG | MEANING | -# +-----------+----------------------+ -# | -L | follow redirects | -# | -o elm.gz | name the file elm.gz | -# +-----------+----------------------+ -# -curl -L -o elm.gz https://github.com/elm/compiler/releases/download/0.19.0/binary-for-linux-64-bit.gz - -# There should now be a file named `elm.gz` on your Desktop. -# -# The downloaded file is compressed to make it faster to download. -# This next command decompresses it, replacing `elm.gz` with `elm`. -# -gunzip elm.gz - -# There should now be a file named `elm` on your Desktop! -# -# Every file has "permissions" about whether it can be read, written, or executed. -# So before we use this file, we need to mark this file as executable: -# -chmod +x elm - -# The `elm` file is now executable. That means running `~/Desktop/elm --help` -# should work. Saying `./elm --help` works the same. -# -# But we want to be able to say `elm --help` without specifying the full file -# path every time. We can do this by moving the `elm` binary to one of the -# directories listed in your `PATH` environment variable: -# -sudo mv elm /usr/local/bin/ - -# Now it should be possible to run the `elm` binary just by saying its name! -# -elm --help -``` - -
- -## Wait, what is the `PATH` variable? - -When you run a command like `elm make src/Main.elm`, your computer starts by trying to find an executable file called `elm`. - -The `PATH` is the list of directories that get searched. You can see these directories by running: - -```bash -echo $PATH -``` - -This prints `/usr/bin:/bin:/usr/sbin:/sbin:/usr/local/bin` on my computer. The directories are separated by a `:` so there are five possibilities listed here. - -When I run `elm make src/Main.elm`, my terminal starts by searching these five directories for an executable file named `elm`. It finds `/usr/local/bin/elm` and then runs `/usr/local/bin/elm make src/Main.elm` with whatever arguments I gave. - -So the `PATH` environment variable is a convention that allows you to refer to a specific executable file without knowing exactly where it lives on your computer. This is actually how all "terminal commands" work! Commands like `ls` are really executable files that live in directories listed in your `PATH` variable. - -So the point of running `sudo mv elm /usr/local/bin/` is to turn the `elm` binary into a terminal command, allowing us to call it just like `ls` and `cd`. - -**Note:** Why do we need to use `sudo` for that one command? Imagine if some program was able to add executables named `ls` or `cd` to `/usr/local/bin` that did something tricky and unexpected. That would be a security problem! Many distributions make this scenario less likely by requiring special permissions to modify the `/usr/local/bin/` directory. - - -
- -## Uninstall - -The following commands should remove everything: - -```bash -# Remove the `elm` executable. -# -sudo rm /usr/local/bin/elm - -# Remove any cached files. The files here reduce compile times when -# starting new projects and make it possible to work offline in more -# cases. No need to keep it around if you are uninstalling though! -# -rm -r ~/.elm/ -``` - -If you have any Elm projects still on your computer, you can remove their `elm-stuff/` directories as well. - diff --git a/installers/mac/Distribution.xml b/installers/mac/Distribution.xml deleted file mode 100644 index 757673c8f2..0000000000 --- a/installers/mac/Distribution.xml +++ /dev/null @@ -1,33 +0,0 @@ - - - Elm - - - - - - - - - - - - - - binaries.pkg - diff --git a/installers/mac/README.md b/installers/mac/README.md deleted file mode 100644 index d8e271d803..0000000000 --- a/installers/mac/README.md +++ /dev/null @@ -1,91 +0,0 @@ -# Install Instructions - -It is easier to use the Mac installer, but it should be possible to install by running the following commands in your terminal: - -```bash -# Move to your Desktop so you can see what is going on easier. -# -cd ~/Desktop/ - -# Download the 0.19.0 binary for Linux. -# -# +-----------+----------------------+ -# | FLAG | MEANING | -# +-----------+----------------------+ -# | -L | follow redirects | -# | -o elm.gz | name the file elm.gz | -# +-----------+----------------------+ -# -curl -L -o elm.gz https://github.com/elm/compiler/releases/download/0.19.0/binary-for-mac-64-bit.gz - -# There should now be a file named `elm.gz` on your Desktop. -# -# The downloaded file is compressed to make it faster to download. -# This next command decompresses it, replacing `elm.gz` with `elm`. -# -gunzip elm.gz - -# There should now be a file named `elm` on your Desktop! -# -# Every file has "permissions" about whether it can be read, written, or executed. -# So before we use this file, we need to mark this file as executable: -# -chmod +x elm - -# The `elm` file is now executable. That means running `~/Desktop/elm --help` -# should work. Saying `./elm --help` works the same. -# -# But we want to be able to say `elm --help` without specifying the full file -# path every time. We can do this by moving the `elm` binary to one of the -# directories listed in your `PATH` environment variable: -# -sudo mv elm /usr/local/bin/ - -# Now it should be possible to run the `elm` binary just by saying its name! -# -elm --help -``` - -
- -## What is the `PATH` variable? - -When you run a command like `elm make src/Main.elm`, your computer starts by trying to find an executable file called `elm`. - -The `PATH` is the list of directories that get searched. You can see these directories by running: - -```bash -echo $PATH -``` - -This prints `/usr/bin:/bin:/usr/sbin:/sbin:/usr/local/bin` on my computer. The directories are separated by a `:` so there are five possibilities listed here. - -When I run `elm make src/Main.elm`, my terminal starts by searching these five directories for an executable file named `elm`. It finds `/usr/local/bin/elm` and then runs `/usr/local/bin/elm make src/Main.elm` with whatever arguments I gave. - -So the `PATH` environment variable is a convention that allows you to refer to a specific executable file without knowing exactly where it lives on your computer. This is actually how all "terminal commands" work! Commands like `ls` are really executable files that live in directories listed in your `PATH` variable. - -So the point of running `sudo mv elm /usr/local/bin/` is to turn the `elm` binary into a terminal command, allowing us to call it just like `ls` and `cd`. - -**Note:** Why do we need to use `sudo` for that one command? Imagine if some program was able to add executables named `ls` or `cd` to `/usr/local/bin` that did something tricky and unexpected. That would be a security problem! Many distributions make this scenario less likely by requiring special permissions to modify the `/usr/local/bin/` directory. - - -
- -## Uninstall - -The following commands should remove everything: - -```bash -# Remove the `elm` executable. -# -sudo rm /usr/local/bin/elm - -# Remove any cached files. The files here reduce compile times when -# starting new projects and make it possible to work offline in more -# cases. No need to keep it around if you are uninstalling though! -# -rm -r ~/.elm/ -``` - -If you have any Elm projects still on your computer, you can remove their `elm-stuff/` directories as well. - diff --git a/installers/mac/Resources/en.lproj/conclusion.rtf b/installers/mac/Resources/en.lproj/conclusion.rtf deleted file mode 100644 index 15b7b36783..0000000000 --- a/installers/mac/Resources/en.lproj/conclusion.rtf +++ /dev/null @@ -1,16 +0,0 @@ -{\rtf1\ansi\ansicpg1252\cocoartf2509 -\cocoatextscaling0\cocoaplatform0{\fonttbl\f0\fswiss\fcharset0 Helvetica;\f1\fmodern\fcharset0 CourierNewPSMT;} -{\colortbl;\red255\green255\blue255;} -{\*\expandedcolortbl;;} -\paperw11900\paperh16840\margl1440\margr1440\vieww11180\viewh8400\viewkind0 -\pard\tx720\tx1440\tx2160\tx2880\tx3600\tx4320\tx5040\tx5760\tx6480\tx7200\tx7920\tx8640\pardirnatural\partightenfactor0 - -\f0\fs28 \cf0 Try opening the terminal and running commands like:\ -\ - -\f1 elm init\ -elm make src/Main.elm --optimize\ -elm repl -\f0 \ -\ -Check out {\field{\*\fldinst{HYPERLINK "https://guide.elm-lang.org/"}}{\fldrslt this tutorial}} for more advice!} \ No newline at end of file diff --git a/installers/mac/Resources/en.lproj/welcome.rtf b/installers/mac/Resources/en.lproj/welcome.rtf deleted file mode 100644 index 17f77e0d1a..0000000000 --- a/installers/mac/Resources/en.lproj/welcome.rtf +++ /dev/null @@ -1,12 +0,0 @@ -{\rtf1\ansi\ansicpg1252\cocoartf2509 -\cocoatextscaling0\cocoaplatform0{\fonttbl\f0\fswiss\fcharset0 Helvetica;\f1\fmodern\fcharset0 CourierNewPSMT;} -{\colortbl;\red255\green255\blue255;} -{\*\expandedcolortbl;;} -\paperw11900\paperh16840\margl1440\margr1440\vieww10800\viewh8400\viewkind0 -\pard\tx566\tx1133\tx1700\tx2267\tx2834\tx3401\tx3968\tx4535\tx5102\tx5669\tx6236\tx6803\pardirnatural\partightenfactor0 - -\f0\fs28 \cf0 Thank you for trying out Elm!\ -\ -This installer makes -\f1 elm -\f0 available in your terminal.} \ No newline at end of file diff --git a/installers/mac/helper-scripts/elm-startup.sh b/installers/mac/helper-scripts/elm-startup.sh deleted file mode 100755 index 5dcb69f74d..0000000000 --- a/installers/mac/helper-scripts/elm-startup.sh +++ /dev/null @@ -1,3 +0,0 @@ -#!/bin/sh - -open 'http://guide.elm-lang.org' diff --git a/installers/mac/helper-scripts/uninstall.sh b/installers/mac/helper-scripts/uninstall.sh deleted file mode 100755 index f36849242f..0000000000 --- a/installers/mac/helper-scripts/uninstall.sh +++ /dev/null @@ -1,21 +0,0 @@ -#!/bin/sh - -set -e - -echo "Warning: You are about to remove all Elm executables!" - -installdir=/usr/local/bin - -for bin in elm elm-compiler elm-get elm-reactor elm-repl elm-doc elm-server elm-package elm-make -do - if [ -f $installdir/$bin ]; then - sudo rm -f $installdir/$bin - fi - if [ -f $installdir/$bin-unwrapped ]; then - sudo rm -f $installdir/$bin-unwrapped - fi - -done - -sharedir=/usr/local/share/elm -sudo rm -rf $sharedir diff --git a/installers/mac/make-installer.sh b/installers/mac/make-installer.sh deleted file mode 100755 index 79d78928ee..0000000000 --- a/installers/mac/make-installer.sh +++ /dev/null @@ -1,54 +0,0 @@ -#!/bin/sh -# Run the following command to create an installer: -# -# bash make-installer.sh -# - - - -#### SETUP #### - -set -e - -# Create directory structure for new pkgs -pkg_root=$(mktemp -d -t package-artifacts) -pkg_binaries=$pkg_root -pkg_scripts=$pkg_root/Scripts - -mkdir -p $pkg_binaries -mkdir -p $pkg_scripts - -usr_binaries=/usr/local/bin - - -#### BUILD ASSETS #### - -cp ../../dist/build/elm/elm $pkg_binaries/elm - -cp $(pwd)/preinstall $pkg_scripts -cp $(pwd)/postinstall $pkg_scripts - -pkgbuild \ - --identifier org.elm-lang.binaries.pkg \ - --install-location $usr_binaries \ - --scripts $pkg_scripts \ - --filter 'Scripts.*' \ - --root $pkg_root \ - binaries.pkg - - -#### BUNDLE ASSETS #### - -rm -f Elm.pkg - -productbuild \ - --distribution Distribution.xml \ - --package-path . \ - --resources Resources \ - Elm.pkg - - -#### CLEAN UP #### - -rm binaries.pkg -rm -rf $pkg_root diff --git a/installers/mac/postinstall b/installers/mac/postinstall deleted file mode 100755 index 4b073d0bf7..0000000000 --- a/installers/mac/postinstall +++ /dev/null @@ -1,5 +0,0 @@ -#!/bin/sh - -set -ex - -echo "$(date)" > /tmp/elm-installer.log diff --git a/installers/mac/preinstall b/installers/mac/preinstall deleted file mode 100755 index 2c18864221..0000000000 --- a/installers/mac/preinstall +++ /dev/null @@ -1,18 +0,0 @@ -#!/bin/sh - -set -e - -installdir=/usr/local/bin - -for bin in elm elm-compiler elm-package elm-reactor elm-repl -do - if [ -f $installdir/$bin ]; then - sudo rm -f $installdir/$bin - fi - if [ -f $installdir/$bin-unwrapped ]; then - sudo rm -f $installdir/$bin-unwrapped - fi -done - -sharedir=/usr/local/share/elm -sudo rm -rf $sharedir diff --git a/installers/npm/.gitignore b/installers/npm/.gitignore deleted file mode 100644 index c2658d7d1b..0000000000 --- a/installers/npm/.gitignore +++ /dev/null @@ -1 +0,0 @@ -node_modules/ diff --git a/installers/npm/.npmignore b/installers/npm/.npmignore deleted file mode 100644 index d69d5759bc..0000000000 --- a/installers/npm/.npmignore +++ /dev/null @@ -1,3 +0,0 @@ -README.md -.gitignore -.git diff --git a/installers/npm/PUBLISHING.md b/installers/npm/PUBLISHING.md deleted file mode 100644 index e5cc774879..0000000000 --- a/installers/npm/PUBLISHING.md +++ /dev/null @@ -1,171 +0,0 @@ -# Publishing a new release - -A new version of Elm came out. Huzzah! Here's how to update the `npm` installer. - -## 1. Create tarballs of binaries - -You can find a list of what binaries we'll need to tar up in `index.js`. - -For example: - -```javascript -var root = - "https://github.com/elm/compiler/releases/download/" + - binVersion + - "/binaries-for-"; - -module.exports = binwrap({ - binaries: ["elm"], - urls: { - "darwin-x64": root + "mac.tar.gz", - "win32-x64": root + "windows.tar.gz", - "win32-ia32": root + "windows.tar.gz", - "linux-x64": root + "linux.tar.gz" - } -}); -``` - -If this is the end of your `index.js`, you'll need to create these files: - -1. `binaries-for-mac.tar.gz` -2. `binaries-for-windows.tar.gz` -3. `binaries-for-linux.tar.gz` - -Each of these tarballs should have **only the Elm binary** inside them - no -directories! - -So create them by making a directory, putting all the binaries in it, `cd`-ing -into that directory, and then running something like this: - -```shell -$ tar cvzf binaries-for-linux.tar.gz elm -``` - -Make sure each tarball contains all the binaries listed in that `binaries:` list -in `index.js`. (The Windows ones should have `.exe` at the end; `binwrap` -expects that they will, for Windows only.) - -## 2. Update the `bin/` binary wrappers - -Inside the npm installer's `bin/` directory, there should be a file for each of -the binaries that will be included in this release. - -Each of these must be executable! If you're not sure whether they are, -run `chmod +x` on them just to be sure. - -Their paths must also must all be listed in `package.json` in two places: - -1. The `"files":` field -2. The `"bin":` field - -If the executables are the same as they were for the last release, great! -You can proceed to the next step. If any binaries were removed, make sure to -remove them from these lists! - -## 3. Update `package.json` for a beta release - -In `package.json`, bump the version to the next applicable release, and add -a `"-beta"` suffix to it. - -For example, if it was on `"0.18.0"` you might bump it to `"0.19.0-beta"`. -The version number should match the release of Elm, such that if people do -`npm install elm@0.19.0@beta` they get what they would expect. - -## 4. Tag the beta release - -Commit this change and tag it with the name of the release **without** the -`-beta` suffix. (We will overwrite this tag later.) - -For example: - -```shell -$ git tag 0.19.0 -$ git push origin 0.19.0 -``` - -Now this tag should exist on GitHub, allowing us to upload binaries to it. - -## 5. Upload binaries - -Visit the [Create a New Release](https://github.com/elm-lang/elm-platform/releases/new) -page and use the `Tag version` dropdown to select the tag you just pushed. Give -it a title like `0.19.0`. Don't mention the `-beta` in it. The "beta" concept -is for `npm` only. - -Upload the tarballs you created in step 1. - -## 6. Publish beta release - -Run this to publish the beta release. The `--tag beta` is **crucial** here. -Without it, `npm` will by default publish a new top-level release, which would -mean that what you just published would become what everyone gets when they -`npm install -g elm` without any additional qualifiers. - -```shell -$ npm publish --tag beta -``` - -Afterwards you should be able to do `npm info elm | less` and see something -like this in the JSON: - -``` -'dist-tags': { latest: '0.18.0', beta: '0.19.0-beta' } -``` - -If you messed this up, and the `latest` tag now points to the beta you just -published, don't panic - it's fixable! `dist-tags` can always be modified after -the fact. Read up on `npm` [dist-tags](https://docs.npmjs.com/cli/dist-tag) -to learn how to fix things. - -## 7. Verify beta installer - -Make an empty directory and run `npm init` inside it. - -Then run this: - -```shell -$ npm install elm@beta --ignore-scripts -``` - -This should succeed with an exit code of `0`. -If it did, look in `node_modules/.bin/` for the binaries you expect. -They should be present, and they should also work as expected when you run them. -Because you installed them with `--ignore-scripts`, the first thing they should -do is to download themselves and then execute whatever command you requested -(e.g. `node_modules/.bin/elm make Main.elm`). If you run the same command a -second time, it should run faster because it doesn't have to download the binary -first. - -Now try it again with `--ignore-scripts` turned off: - -```shell -$ rm -r node_modules -$ npm install elm@beta --ignore-scripts=false -``` - -This time it should download the binaries during the installation phase. Once -again you should be able to run the binaries from `node_modules/.bin/`, and -this time they should be fast from the first run because they're already -downloaded. - -## 8. Publish for real - -It's a good idea to ask others to try out the beta installer before doing this! -Especially on multiple operating systems. - -To publish the real version: - -1. Edit `package.json` to remove the `-beta` suffix from the version. -2. Commit that change and push it. -3. Use `git tag --force` to overwrite the previous tag (e.g. `0.19.0` - whatever you used before). -4. Force push the tag, e.g. `git push origin 0.19.0 --force-with-lease`. -5. `npm publish` - -You're done! Now whenever anyone does `npm install -g elm` they'll get the -version you just uploaded. - -The reason we only used the `-beta` suffix for `npm` was so that when we ran -tests on the beta version, it was all against the same (non-beta) URLs we'd end -up using for the real version. This means there's no opportunity for us to -introduce some sort of mismatch between the beta that we verified and the real -version. diff --git a/installers/npm/README.md b/installers/npm/README.md deleted file mode 100644 index b8886ad155..0000000000 --- a/installers/npm/README.md +++ /dev/null @@ -1,34 +0,0 @@ -# npm install elm - -[Elm](https://elm-lang.org) is a functional programming language that compiles to JavaScript. - -There are installers for Mac and Windows available [here](https://github.com/elm/compiler/releases/tag/0.19.1). There are also binaries for direct download. These are the most reliable ways to install Elm. - -This package tries to download those binaries with `npm`. It is sometimes used by people intergating Elm into existing projects or workflows. - -
- - -## Install - -The following command should download the `elm` binary: - -``` -npm install -g elm -``` - -If this runs successfully, the `elm` binary should be available at: - -- `/usr/local/bin/elm` on Mac and Linux -- `C:\Users\YOUR_NAME\AppData\Roaming\npm\` on Windows - -It should be possible to run `elm` from your terminal after this. - -If you run into trouble, check out [troubleshooting.md](troubleshooting.md). - -
- - -## What is next? - -Head over to [The Official Guide](https://guide.elm-lang.org/) to start learning Elm! diff --git a/installers/npm/bin/elm b/installers/npm/bin/elm deleted file mode 100755 index 612e933a9d..0000000000 --- a/installers/npm/bin/elm +++ /dev/null @@ -1,47 +0,0 @@ -#!/usr/bin/env node - -var child_process = require('child_process'); -var path = require('path'); -var fs = require('fs'); - - -// Some npm users enable --ignore-scripts (a good security measure) so -// they do not run the post-install hook and install.js does not run. -// Instead they will run this script. -// -// On Mac and Linux, we download the elm executable into the exact same -// location as this file. Since npm uses symlinks on these platforms, -// that means that the first run will invoke this file and subsequent -// runs will call the elm binary directly. -// -// On Windows, we must download a file named elm.exe for it to run properly. -// Instead of symlinks, npm creates two files: -// -// - node_modules/.bin/elm (a bash file) -// - node_modules/.bin/elm.cmd (a batch file) -// -// Both files specifically invoke `node` to run the file listed at package.bin, -// so there is no way around instantiating node for no reason on Windows. So -// the existsSync check is needed so that it is not downloaded more than once. - - -// figure out where to put the binary (calls path.resolve() to get path separators right on Windows) -// -var binaryPath = path.resolve(__dirname, 'elm') + (process.platform === 'win32' ? '.exe' : ''); - -// Run the command directly if possible, otherwise download and then run. -// This check is important for Windows where this file will be run all the time. -// -fs.existsSync(binaryPath) - ? runCommand() - : require('../download.js')(runCommand); - - -function runCommand() -{ - // Need double quotes and { shell: true } when there are spaces in the path on windows: - // https://github.com/nodejs/node/issues/7367#issuecomment-229721296 - child_process - .spawn('"' + binaryPath + '"', process.argv.slice(2), { stdio: 'inherit', shell: true }) - .on('exit', process.exit); -} diff --git a/installers/npm/download.js b/installers/npm/download.js deleted file mode 100644 index 6ced746e6f..0000000000 --- a/installers/npm/download.js +++ /dev/null @@ -1,82 +0,0 @@ -var fs = require('fs'); -var package = require('./package.json'); -var path = require('path'); -var request = require('request'); -var zlib = require('zlib'); - - - -// MAIN -// -// This function is used by install.js and by the bin/elm backup that gets -// called when --ignore-scripts is enabled. That's why install.js is so weird. - - -module.exports = function(callback) -{ - // figure out URL of binary - var version = package.version.replace(/^(\d+\.\d+\.\d+).*$/, '$1'); // turn '1.2.3-alpha' into '1.2.3' - var os = { 'darwin': 'mac', 'win32': 'windows', 'linux': 'linux' }[process.platform]; - var arch = { 'x64': '64-bit', 'ia32': '32-bit' }[process.arch]; - var url = 'https://github.com/elm/compiler/releases/download/' + version + '/binary-for-' + os + '-' + arch + '.gz'; - - reportDownload(version, url); - - // figure out where to put the binary (calls path.resolve() to get path separators right on Windows) - var binaryPath = path.resolve(__dirname, package.bin) + (process.platform === 'win32' ? '.exe' : ''); - - // set up handler for request failure - function reportDownloadFailure(error) - { - exitFailure(url,'Something went wrong while fetching the following URL:\n\n' + url + '\n\nIt is saying:\n\n' + error); - } - - // set up decompression pipe - var gunzip = zlib.createGunzip().on('error', function(error) { - exitFailure(url, 'I ran into trouble decompressing the downloaded binary. It is saying:\n\n' + error); - }); - - // set up file write pipe - var write = fs.createWriteStream(binaryPath, { - encoding: 'binary', - mode: 0o755 - }).on('finish', callback).on('error', function(error) { - exitFailure(url, 'I had some trouble writing file to disk. It is saying:\n\n' + error); - }); - - // put it all together - request(url).on('error', reportDownloadFailure).pipe(gunzip).pipe(write); -} - - - -// EXIT FAILURE - - -function exitFailure(url, message) -{ - console.error( - '-- ERROR -----------------------------------------------------------------------\n\n' - + message - + '\n\nNOTE: You can avoid npm entirely by downloading directly from:\n' - + url + '\nAll this package does is download that file and put it somewhere.\n\n' - + '--------------------------------------------------------------------------------\n' - ); - process.exit(1); -} - - - -// REPORT DOWNLOAD - - -function reportDownload(version, url) -{ - console.log( - '--------------------------------------------------------------------------------\n\n' - + 'Downloading Elm ' + version + ' from GitHub.' - + '\n\nNOTE: You can avoid npm entirely by downloading directly from:\n' - + url + '\nAll this package does is download that file and put it somewhere.\n\n' - + '--------------------------------------------------------------------------------\n' - ); -} diff --git a/installers/npm/install.js b/installers/npm/install.js deleted file mode 100644 index 93083e0616..0000000000 --- a/installers/npm/install.js +++ /dev/null @@ -1,4 +0,0 @@ - -var download = require('./download.js'); - -download(function() {}); diff --git a/installers/npm/package.json b/installers/npm/package.json deleted file mode 100644 index 9795c76b85..0000000000 --- a/installers/npm/package.json +++ /dev/null @@ -1,42 +0,0 @@ -{ - "name": "elm", - "version": "0.19.1", - "description": "Installer for Elm: just downloads the binary into node_modules", - "preferGlobal": true, - "license": "BSD-3-Clause", - "repository": { - "type": "git", - "url": "https://github.com/elm/compiler.git" - }, - "homepage": "https://github.com/elm/compiler/tree/master/installers/npm", - "bugs": "https://github.com/elm/compiler/issues", - "author": { - "name": "Evan Czaplicki", - "email": "evan@elm-lang.org", - "url": "https://github.com/evancz" - }, - "engines": { - "node": ">=7.0.0" - }, - "scripts": { - "install": "node install.js" - }, - "files": [ - "install.js", - "download.js", - "bin", - "bin/elm" - ], - "keywords": [ - "bin", - "binary", - "binaries", - "elm", - "install", - "installer" - ], - "bin": "bin/elm", - "dependencies": { - "request": "^2.88.0" - } -} diff --git a/installers/npm/troubleshooting.md b/installers/npm/troubleshooting.md deleted file mode 100644 index aafcf9bf54..0000000000 --- a/installers/npm/troubleshooting.md +++ /dev/null @@ -1,76 +0,0 @@ -# Troubleshooting - -I very highly recommend asking for help on [the Elm slack](https://elmlang.herokuapp.com). - -There are a lot of things that can go wrong when installing software, and it can really help to have a second pair of eyes on your situation! - -This document goes through a couple options that may help you out. - -
- - -## Can you skip npm entirely? - -The most reliable way to get Elm installed using the official installers for Mac and Windows [here][download]. - -You can also download the binaries directly. On Linux, you could do it in the terminal like this: - -```bash -cd ~/Desktop/ -curl -L -o elm.gz https://github.com/elm/compiler/releases/download/0.19.1/binary-for-linux-64-bit.gz -gunzip elm.gz # unzip the file -chmod +x elm # make the file executable -sudo mv elm /usr/local/bin/ # put the executable in a directory likely to be listed in your PATH variable -``` - -If these exact commands do not work for you, you can try to do the same thing by hand. - -Read the section below on `PATH` variables if you are not sure what that is! - -[download]: https://github.com/elm/compiler/releases/tag/0.19.1 - -
- - -## Do you need to use npm for some reason? - -The company running npm has a list of common troubleshooting situations [here](https://npm.community/c/support/troubleshooting), but it may be better to just try to find your specific case on Stack Overflow. Often there are permissions issues where you may need to use `sudo` with some command. - -### Firewalls - -Some companies have a firewall. - -These companies usually have set the `HTTP_PROXY` or `HTTPS_PROXY` environment variable on your computer. This is more common with Windows computers. - -The result is that the request for `https://github.com/elm/compiler/releases/download/0.19.1/binary-for-windows-64-bit.gz` is being sent to a "proxy server" where they monitor traffic. Maybe they rule out certain domains, maybe they check data when it comes back from the actual URL, etc. - -It is probably best to ask someone about the situation on this, but you can test things out by temporarily using an alternate `HTTPS_PROXY` value with something like this: - -``` -# Mac and Linux -HTTPS_PROXY=http://proxy.example.com npm install -g elm - -# Windows -set HTTPS_PROXY=http://proxy.example.com -npm install -g elm -``` - -Check out [this document](https://www.npmjs.com/package/request#controlling-proxy-behaviour-using-environment-variables) for more information on how environment variables like `NO_PROXY`, `HTTP_PROXY`, and `HTTPS_PROXY` are handled by the npm. - -
- - -## Do you know what a `PATH` variable is? - -When you run a command like `elm make src/Main.elm`, your computer starts by trying to find a file called `elm`. - -The `PATH` is a list of directories to search within. On Mac and Linux, you can see these directories by running: - -``` -$ echo $PATH -/usr/bin:/bin:/usr/sbin:/sbin:/usr/local/bin:/usr/local/git/bin -``` - -The are separated by `:` for some reason. So running `elm make src/Main.elm` starts by searching the `PATH` for files named `elm`. On my computer, it finds `/usr/local/bin/elm` and then can actually run the command. - -Is `elm` in one of the directories listed in your `PATH` variable? I recommend asking for help if you are in this scenario and unsure how to proceed. diff --git a/installers/win/CreateInternetShortcut.nsh b/installers/win/CreateInternetShortcut.nsh deleted file mode 100644 index 8006d1d1d1..0000000000 --- a/installers/win/CreateInternetShortcut.nsh +++ /dev/null @@ -1,5 +0,0 @@ -!macro CreateInternetShortcut FILENAME URL ICONFILE ICONINDEX -WriteINIStr "${FILENAME}.url" "InternetShortcut" "URL" "${URL}" -WriteINIStr "${FILENAME}.url" "InternetShortcut" "IconFile" "${ICONFILE}" -WriteINIStr "${FILENAME}.url" "InternetShortcut" "IconIndex" "${ICONINDEX}" -!macroend \ No newline at end of file diff --git a/installers/win/Nsisfile.nsi b/installers/win/Nsisfile.nsi deleted file mode 100644 index 23b950d531..0000000000 --- a/installers/win/Nsisfile.nsi +++ /dev/null @@ -1,264 +0,0 @@ -; Elm Installer - -;-------------------------------- -;Includes - - !Include "FileFunc.nsh" - !Include "LogicLib.nsh" - !Include "MUI2.nsh" - !Include "WordFunc.nsh" - !Include "CreateInternetShortcut.nsh" - -;-------------------------------- -;Defines - - !Define PRODUCT_DIR_REG_KEY "Software\Elm\Elm\${PLATFORM_VERSION}" - !Define FILES_SOURCE_PATH "files" - !Define INST_DAT "inst.dat" - !Define UNINST_DAT "uninst.dat" - -;-------------------------------- -;Variables - - Var START_MENU_FOLDER - -;-------------------------------- -;General settings - - ;Name and file - Name "Elm ${PLATFORM_VERSION}" - OutFile "Elm-${PLATFORM_VERSION}.exe" - - ;Default install dir - InstallDir "$PROGRAMFILES\Elm\${PLATFORM_VERSION}" - InstallDirRegKey HKLM "${PRODUCT_DIR_REG_KEY}" "" - - ;Icon - !Define MUI_ICON "logo.ico" - !Define MUI_UNICON "logo.ico" - - ;Request application privileges for Windows Vista - RequestExecutionLevel highest - - ;Best available compression - SetCompressor /SOLID lzma - - ;Install types - InstType "Standard" - InstType "Portable (just unpack the files)" - -;-------------------------------- -;Macros - -!macro CheckAdmin thing -UserInfo::GetAccountType -pop $0 -${If} $0 != "admin" ;Require admin rights on NT4+ - MessageBox MB_YESNO "It is recommended to run this ${thing} as administrator. Do you want to quit and restart the ${thing} manually with elevated privileges?" IDNO CheckAdminDone - SetErrorLevel 740 ;ERROR_ELEVATION_REQUIRED - Quit -${EndIf} -CheckAdminDone: -!macroend - -;-------------------------------- -;Callbacks - -Function .onInit - !insertmacro CheckAdmin "installer" - SetShellVarContext all -FunctionEnd - -Function un.onInit - !insertmacro CheckAdmin "uninstaller" - SetShellVarContext all -FunctionEnd - -Function LaunchLink - ExecShell "open" "https://guide.elm-lang.org" -FunctionEnd - -;-------------------------------- -;Interface Settings - - !define MUI_ABORTWARNING - -;-------------------------------- -;Pages - - !Define MUI_WELCOMEFINISHPAGE_BITMAP "welcome.bmp" - !insertmacro MUI_PAGE_WELCOME - ;!insertmacro MUI_PAGE_LICENSE "LICENSE" - !insertmacro MUI_PAGE_DIRECTORY - - !Define MUI_COMPONENTSPAGE_NODESC - !insertmacro MUI_PAGE_COMPONENTS - - ;Start Menu Folder Page Configuration - !Define MUI_PAGE_HEADER_SUBTEXT \ - "Choose a Start Menu folder for the Elm ${PLATFORM_VERSION} shortcuts." - !Define MUI_STARTMENUPAGE_TEXT_TOP \ - "Select the Start Menu folder in which you would like to create Elm shortcuts. You can also enter a name to create a new folder." - !Define MUI_STARTMENUPAGE_REGISTRY_ROOT "HKLM" - !Define MUI_STARTMENUPAGE_REGISTRY_KEY "${PRODUCT_DIR_REG_KEY}" - !Define MUI_STARTMENUPAGE_REGISTRY_VALUENAME "Start Menu Folder" - !Define MUI_STARTMENUPAGE_DEFAULTFOLDER "Elm ${PLATFORM_VERSION}" - !insertmacro MUI_PAGE_STARTMENU StartMenuPage $START_MENU_FOLDER - !insertmacro MUI_PAGE_INSTFILES - !define MUI_FINISHPAGE_RUN - !define MUI_FINISHPAGE_RUN_FUNCTION "LaunchLink" - !define MUI_FINISHPAGE_RUN_TEXT "Open tutorial on how to use Elm" - !insertmacro MUI_PAGE_FINISH - - !insertmacro MUI_UNPAGE_WELCOME - !insertmacro MUI_UNPAGE_CONFIRM - !insertmacro MUI_UNPAGE_INSTFILES - !insertmacro MUI_UNPAGE_FINISH - -;-------------------------------- -;Languages - - !insertmacro MUI_LANGUAGE "English" - -;-------------------------------- -;Installer Sections - -Section "Base components" SecMain - - SectionIn 1 2 - ; Make this section mandatory - SectionIn RO - - !Include ${INST_DAT} - -SectionEnd - -SectionGroup "Update system settings" SecGr - -;Section "Associate with .elm files" SecAssoc -; -; SectionIn 1 -; -; ; File associations -; WriteRegStr HKCR ".elm" "" "elm" -; WriteRegStr HKCR "elm" "" "Elm Source File" -; WriteRegStr HKCR "elm\DefaultIcon" "" "$INSTDIR\file.ico" -; WriteRegStr HKCR "elm\shell\open\command" "" '"$INSTDIR\bin\elm.exe" "%1"' -; -; ;Remember that we registered associations -; WriteRegDWORD HKLM "${PRODUCT_DIR_REG_KEY}" Assocs 0x1 -; -;SectionEnd - -Section "Update the PATH environment variable" SecPath - - SectionIn 1 - - ; Update PATH - ; First, remove any older version - ExecWait '"$SYSDIR\wscript.exe" //E:vbscript "$INSTDIR\removefrompath.vbs" "$PROGRAMFILES\Elm"' - ; Then add to the PATH - ExecWait '"$SYSDIR\wscript.exe" //E:vbscript "$INSTDIR\updatepath.vbs" "$INSTDIR\bin"' - SetShellVarContext current - - ; Update environment variables - SendMessage ${HWND_BROADCAST} ${WM_SETTINGCHANGE} 0 "STR:Environment" /TIMEOUT=5000 - -SectionEnd - -Section "Store Elm's location in registry" SecElmLoc - - SectionIn 1 - - ; (copied from the GHC installer). - ;WriteRegStr HKCU "Software\Elm\ghc-${GHC_VERSION}" "InstallDir" "$INSTDIR" - WriteRegStr HKCU "Software\Elm" "InstallDir" "$INSTDIR" - -SectionEnd - -Section "Create uninstaller" SecAddRem - - SectionIn 1 - SectionIn RO - - ; Add uninstall information to Add/Remove Programs - WriteRegStr HKLM "Software\Microsoft\Windows\CurrentVersion\Uninstall\Elm-${PLATFORM_VERSION}" \ - "DisplayName" "Elm ${PLATFORM_VERSION}" - WriteRegStr HKLM "Software\Microsoft\Windows\CurrentVersion\Uninstall\Elm-${PLATFORM_VERSION}" \ - "UninstallString" "$\"$INSTDIR\Uninstall.exe$\"" - WriteRegStr HKLM "Software\Microsoft\Windows\CurrentVersion\Uninstall\Elm-${PLATFORM_VERSION}" \ - "DisplayIcon" "$INSTDIR\logo.ico" - WriteRegStr HKLM "Software\Microsoft\Windows\CurrentVersion\Uninstall\Elm-${PLATFORM_VERSION}" \ - "Publisher" "elm-lang.org" - - ;Create uninstaller - WriteUninstaller "$INSTDIR\Uninstall.exe" - - ; This is needed for uninstaller to work - WriteRegStr HKLM "${PRODUCT_DIR_REG_KEY}" "" "$INSTDIR\Uninstall.exe" - WriteRegStr HKLM "${PRODUCT_DIR_REG_KEY}" "InstallDir" "$INSTDIR" - -SectionEnd - -SectionGroupEnd - -;Section "-StartMenu" StartMenu -; SectionIn 1 2 -; -; ; Add start menu shortcuts -; -; !insertmacro MUI_STARTMENU_WRITE_BEGIN StartMenuPage -; -; ;Create shortcuts -; CreateDirectory "$SMPROGRAMS\$START_MENU_FOLDER" -; !insertmacro CreateInternetShortcut \ -; "$SMPROGRAMS\$START_MENU_FOLDER\${HACKAGE_SHORTCUT_TEXT}" \ -; "http://hackage.haskell.org" \ -; "$INSTDIR\icons\hackage.ico" "0" -; !insertmacro MUI_STARTMENU_WRITE_END -; -;SectionEnd - -;-------------------------------- -;Uninstaller Section - -Section "Uninstall" - - ; Update PATH - ExecWait '"$SYSDIR\wscript.exe" //E:vbscript "$INSTDIR\removefrompath.vbs" "$PROGRAMFILES\Elm"' - SetShellVarContext current - - !Include ${UNINST_DAT} - - Delete "$INSTDIR\Uninstall.exe" - RMDir $INSTDIR - - ;Since we install to '$PF\Elm\$PLATFORM_VERSION', we - ;should also try to delete '$PF\Elm' if it is empty. - ${GetParent} $INSTDIR $R0 - RMDir $R0 - - ; Delete start menu shortcuts - ;!insertmacro MUI_STARTMENU_GETFOLDER StartMenuPage $START_MENU_FOLDER - - ;Delete "$SMPROGRAMS\$START_MENU_FOLDER\${HACKAGE_SHORTCUT_TEXT}.url" - ;RMDir "$SMPROGRAMS\$START_MENU_FOLDER\" - - ; Delete registry keys - - ReadRegDWORD $0 HKLM "${PRODUCT_DIR_REG_KEY}" Assocs - - ${If} $0 = 0x1 - DeleteRegValue HKCR ".elm" "" - DeleteRegKey HKCR "elm\DefaultIcon" - ${EndIf} - - DeleteRegKey HKCU "Software\Elm" - DeleteRegKey HKLM "${PRODUCT_DIR_REG_KEY}" - DeleteRegKey /IfEmpty HKCU Software\Elm - DeleteRegKey HKLM "Software\Microsoft\Windows\CurrentVersion\Uninstall\Elm-${PLATFORM_VERSION}" - - ; Update environment variables - SendMessage ${HWND_BROADCAST} ${WM_SETTINGCHANGE} 0 "STR:Environment" /TIMEOUT=5000 - -SectionEnd diff --git a/installers/win/README.md b/installers/win/README.md deleted file mode 100644 index d24827b1ba..0000000000 --- a/installers/win/README.md +++ /dev/null @@ -1,24 +0,0 @@ -# Installing on Windows - -The installer for Windows is available [here](https://guide.elm-lang.org/install.html). - - -
- -## Uninstall - -First run the `C:\Program Files (x86)\Elm\0.19\uninstall.exe` file. This will remove Elm stuff from your `PATH`. - -Then remove the whole `C:\Users\\AppData\Roaming\elm` directory. Elm caches some packages and build artifacts to reduce compile times and to help you work offline. Getting rid of this directory will clear that information out! - -
- -## Building the Windows installer - -You will need the [NSIS installer](http://nsis.sourceforge.net/Download) to be installed. - -Once everything is installed, run something like this command: - - make_installer.cmd 0.19.0 - -It will build an installer called `Elm-0.19.0-setup.exe`. diff --git a/installers/win/inst.dat b/installers/win/inst.dat deleted file mode 100644 index 2adc7f4c73..0000000000 --- a/installers/win/inst.dat +++ /dev/null @@ -1,6 +0,0 @@ -SetOutPath "$INSTDIR\bin" -File "${FILES_SOURCE_PATH}\bin\elm.exe" - -SetOutPath "$INSTDIR" -File "updatepath.vbs" -File "removefrompath.vbs" diff --git a/installers/win/logo.ico b/installers/win/logo.ico deleted file mode 100644 index 19ad82ae71..0000000000 Binary files a/installers/win/logo.ico and /dev/null differ diff --git a/installers/win/make_installer.cmd b/installers/win/make_installer.cmd deleted file mode 100644 index f58024cd1f..0000000000 --- a/installers/win/make_installer.cmd +++ /dev/null @@ -1,18 +0,0 @@ - -set version=%1 - -mkdir files -mkdir files\bin - -xcopy ..\..\dist\build\elm\elm.exe files\bin /s /e -xcopy updatepath.vbs files - -if EXIST "%ProgramFiles%\NSIS" ( - set nsis="%ProgramFiles%\NSIS\makensis.exe" -) else ( - set nsis="%ProgramFiles(x86)%\NSIS\makensis.exe" -) - -%nsis% /DPLATFORM_VERSION=%version% Nsisfile.nsi - -rd /s /q files diff --git a/installers/win/removefrompath.vbs b/installers/win/removefrompath.vbs deleted file mode 100644 index 554c133580..0000000000 --- a/installers/win/removefrompath.vbs +++ /dev/null @@ -1,17 +0,0 @@ -Set WshShell = CreateObject("WScript.Shell") -' Make sure there is no trailing slash at the end of elmBasePath -elmBasePath = WScript.Arguments(0) -'const PathRegKey = "HKLM\SYSTEM\CurrentControlSet\Control\Session Manager\Environment\Path" -const PathRegKey = "HKCU\Environment\Path" - -on error resume next -path = WshShell.RegRead(PathRegKey) -if err.number = 0 then - Set regEx = New RegExp - elmBasePath = Replace(Replace(Replace(elmBasePath, "\", "\\"), "(", "\("), ")", "\)") - regEx.Pattern = elmBasePath & "\\\d+\.\d+(\.\d+|)\\bin(;|)" - regEx.Global = True - newPath = regEx.Replace(path, "") - Call WshShell.RegWrite(PathRegKey, newPath, "REG_EXPAND_SZ") -end if -on error goto 0 diff --git a/installers/win/uninst.dat b/installers/win/uninst.dat deleted file mode 100644 index fa70d3f0e7..0000000000 --- a/installers/win/uninst.dat +++ /dev/null @@ -1,6 +0,0 @@ -Delete "$INSTDIR\bin\elm.exe" -RmDir "$INSTDIR\bin" - -Delete "$INSTDIR\updatepath.vbs" -Delete "$INSTDIR\removefrompath.vbs" -RmDir "$INSTDIR" diff --git a/installers/win/updatepath.vbs b/installers/win/updatepath.vbs deleted file mode 100644 index 9a30d3362f..0000000000 --- a/installers/win/updatepath.vbs +++ /dev/null @@ -1,14 +0,0 @@ -Set WshShell = CreateObject("WScript.Shell") -elmPath = WScript.Arguments(0) -'const PathRegKey = "HKLM\SYSTEM\CurrentControlSet\Control\Session Manager\Environment\Path" -const PathRegKey = "HKCU\Environment\Path" - -on error resume next -path = WshShell.RegRead(PathRegKey) -if err.number <> 0 then - path = "" -end if -on error goto 0 - -newPath = elmPath & ";" & path -Call WshShell.RegWrite(PathRegKey, newPath, "REG_EXPAND_SZ") diff --git a/installers/win/welcome.bmp b/installers/win/welcome.bmp deleted file mode 100644 index 5e48790d3d..0000000000 Binary files a/installers/win/welcome.bmp and /dev/null differ diff --git a/lib/browser.js b/lib/browser.js new file mode 100644 index 0000000000..dcc1521ea6 --- /dev/null +++ b/lib/browser.js @@ -0,0 +1,379 @@ +const { createFs } = require("indexeddb-fs"); +const { newServer } = require("mock-xmlhttprequest"); +const JSZip = require("jszip"); + +const savedXMLHttpRequest = globalThis.XMLHttpRequest; +const fs = createFs({ databaseName: "guida-fs" }); + +const runGuida = function (extraEnv, args) { + return new Promise((resolve) => { + let mVarsNextCounter = 0; + const mVars = {}; + const lockedFiles = {}; + + const env = Object.assign({ + GUIDA_HOME: "root/.guida", + }, extraEnv); + + const download = function (method, url) { + const that = this; + + const xhr = new savedXMLHttpRequest(); + xhr.open(method, url, true); + xhr.responseType = "arraybuffer"; + + xhr.onload = async () => { + const headers = xhr.getAllResponseHeaders().trim().split(/[\r\n]+/).reduce(function (acc, line) { + const parts = line.split(": "); + const header = parts.shift(); + const value = parts.join(": "); + acc[header] = value; + return acc; + }, {}); + + if (xhr.status >= 200 && xhr.status < 300) { + const hashBuffer = await crypto.subtle.digest("SHA-1", xhr.response); + const sha = Array.from(new Uint8Array(hashBuffer)).map(byte => byte.toString(16).padStart(2, "0")).join(""); + + const jsZip = new JSZip(); + jsZip.loadAsync(xhr.response).then(function async(zip) { + const archive = []; + + Promise.all(Object.entries(zip.files).map(async ([_, file]) => { + return file.async("text").then((eData) => { + archive.push({ + eRelativePath: file.name, + eData + }); + }); + })).then(() => { + that.send({ sha, archive }); + }); + }); + } else if (headers.location) { + download.apply(this, [method, headers.location]); + } + }; + + xhr.onerror = function () { + console.error("Network error during ZIP file download."); + }; + + xhr.ontimeout = function () { + console.error("ZIP file download timed out."); + }; + + xhr.send(); + }; + + const server = newServer(); + + server.post("hPutStr", (request) => { + const fd = parseInt(request.requestHeaders.getHeader("fd")); + + if (fd === 1) { + console.log(request.body); + } else if (fd === 2) { + console.error(request.body); + } else { + throw new Error(`Invalid file descriptor: ${fd}`); + } + + request.respond(200); + }); + + server.post("writeString", async (request) => { + const path = request.requestHeaders.getHeader("path"); + + await fs.writeFile(path, request.body); + request.respond(200); + }); + + server.post("read", async (request) => { + const content = await fs.readFile(request.body); + request.respond(200, null, content); + }); + + + server.post("getArchive", (request) => { + download.apply({ + send: ({ sha, archive }) => { + request.respond(200, null, JSON.stringify({ sha, archive })); + } + }, ["GET", request.body]); + }); + + server.post("dirDoesFileExist", async (request) => { + try { + const stats = await fs.details(request.body); + console.log("dirDoesFileExist", request.body, stats); + request.respond(200, null, stats.type === "file"); + } catch (_err) { + request.respond(200, null, false); + } + }); + + server.post("dirCreateDirectoryIfMissing", async (request) => { + const { createParents, filename } = JSON.parse(request.body); + let directories = [filename]; + + if (createParents) { + directories = filename.split('/').filter(Boolean); + directories = directories.map((_, index) => directories.slice(0, index + 1).join('/')); + } + + await directories.reduce(async (previousPromise, directory) => { + await previousPromise; + + try { + await fs.details(directory); + } catch (_err) { + await fs.createDirectory(directory); + } + }, Promise.resolve()); + + request.respond(200); + }); + + server.post("lockFile", (request) => { + const path = request.body; + + if (lockedFiles[path]) { + lockedFiles[path].subscribers.push(request); + } else { + lockedFiles[path] = { subscribers: [] }; + request.respond(200); + } + }); + + server.post("unlockFile", (request) => { + const path = request.body; + + if (lockedFiles[path]) { + const subscriber = lockedFiles[path].subscribers.shift(); + + if (subscriber) { + subscriber.respond(200); + } else { + delete lockedFiles[path]; + } + + request.respond(200); + } else { + console.error(`Could not find locked file "${path}"!`); + } + }); + + server.post("dirGetModificationTime", async (request) => { + const stats = await fs.details(request.body); + request.respond(200, null, stats.createdAt); + }); + + server.post("dirDoesDirectoryExist", async (request) => { + try { + const stats = await fs.details(request.body); + request.respond(200, null, stats.type === "directory"); + } catch (_err) { + request.respond(200, null, false); + } + }); + + server.post("dirCanonicalizePath", (request) => { + request.respond(200, null, request.body); + }); + + server.post("dirListDirectory", async (request) => { + const { files } = await fs.readDirectory(request.body); + request.respond(200, null, JSON.stringify(files)); + }); + + server.post("binaryDecodeFileOrFail", async (request) => { + const data = await fs.readFile(request.body); + request.respond(200, null, data.buffer); + }); + + server.post("write", async (request) => { + const path = request.requestHeaders.getHeader("path"); + + await fs.writeFile(path, request.body); + request.respond(200); + }); + + server.post("dirGetCurrentDirectory", (request) => { + request.respond(200, null, "root"); + }); + + server.post("envLookupEnv", (request) => { + const envVar = env[request.body] ?? null; + request.respond(200, null, JSON.stringify(envVar)); + }); + + server.post("dirGetAppUserDataDirectory", (request) => { + request.respond(200, null, `root/.${request.body}`); + }); + + // MVARS + server.post("newEmptyMVar", (request) => { + mVarsNextCounter += 1; + mVars[mVarsNextCounter] = { subscribers: [], value: undefined }; + request.respond(200, null, mVarsNextCounter); + }); + + server.post("readMVar", (request) => { + const id = request.body; + + if (typeof mVars[id].value === "undefined") { + mVars[id].subscribers.push({ action: "read", request }); + } else { + request.respond(200, null, mVars[id].value.buffer); + } + }); + + server.post("takeMVar", (request) => { + const id = request.body; + + if (typeof mVars[id].value === "undefined") { + mVars[id].subscribers.push({ action: "take", request }); + } else { + const value = mVars[id].value; + mVars[id].value = undefined; + + if ( + mVars[id].subscribers.length > 0 && + mVars[id].subscribers[0].action === "put" + ) { + const subscriber = mVars[id].subscribers.shift(); + mVars[id].value = subscriber.value; + request.respond(200); + } + + request.respond(200, null, value.buffer); + } + }); + + server.post("putMVar", (request) => { + const id = request.requestHeaders.getHeader("id"); + const value = request.body; + + if (typeof mVars[id].value === "undefined") { + mVars[id].value = value; + + mVars[id].subscribers = mVars[id].subscribers.filter((subscriber) => { + if (subscriber.action === "read") { + subscriber.request.respond(200, null, value.buffer); + } + + return subscriber.action !== "read"; + }); + + const subscriber = mVars[id].subscribers.shift(); + + if (subscriber) { + subscriber.request.respond(200, null, value.buffer); + + if (subscriber.action === "take") { + mVars[id].value = undefined; + } + } + + request.respond(200); + } else { + mVars[id].subscribers.push({ action: "put", request, value }); + } + }); + + // BROWSER + server.post("getArgs", (request) => { + request.respond(200, null, JSON.stringify(args)); + }); + + server.post("exitWithResponse", (request) => { + resolve(JSON.parse(request.body)); + }); + + // Catch non-implemented functionality + server.post(/^\w+$/, (request) => { + throw new Error(`${request.url} handler not implemented!`); + }); + + server.setDefaultHandler((request) => { + console.log("defaultHandler", request.url); + + const headers = request.requestHeaders.getHash(); + + var xhr = new savedXMLHttpRequest(); + xhr.open(request.method, request.url, true); + + for (const key in headers) { + if (Object.prototype.hasOwnProperty.call(headers, key) && key !== "user-agent") { + xhr.setRequestHeader(key, headers[key]); + } + } + xhr.onload = function () { + request.respond(200, null, this.responseText); + }; + xhr.send(request.body); + }); + + server.install(); + + const { Elm } = require("./guida.browser.min.js"); + + Elm.Browser.Main.init(); + }); +} + +const elmJsonContent = `{ + "type": "application", + "source-directories": [ + "src" + ], + "elm-version": "0.19.1", + "dependencies": { + "direct": { + "elm/browser": "1.0.2", + "elm/core": "1.0.5", + "elm/html": "1.0.0" + }, + "indirect": { + "elm/json": "1.1.3", + "elm/time": "1.0.0", + "elm/url": "1.0.0", + "elm/virtual-dom": "1.0.3" + } + }, + "test-dependencies": { + "direct": {}, + "indirect": {} + } +}`; + +module.exports = { + init: async (extraEnv) => { + await fs.writeFile("root/elm.json", elmJsonContent); + await fs.createDirectory("root/src"); + + return { + make: async (content, options) => { + await fs.writeFile("root/src/Main.guida", content); + + return await runGuida(extraEnv, { + command: "make", + path: "src/Main.guida", + debug: !!options.debug, + optimize: !!options.optimize, + sourcemaps: !!options.sourcemaps + }); + }, + format: async (content) => { + return await runGuida(extraEnv, { command: "format", content }); + }, + install: async (pkg) => { + return await runGuida(extraEnv, { command: "install", pkg }); + }, + uninstall: async (pkg) => { + return await runGuida(extraEnv, { command: "uninstall", pkg }); + } + }; + } +}; \ No newline at end of file diff --git a/lib/node.d.ts b/lib/node.d.ts new file mode 100644 index 0000000000..4de296a67b --- /dev/null +++ b/lib/node.d.ts @@ -0,0 +1,3 @@ +export function init(extraEnv?: any): { + format: (content: string) => { output?: string, error?: any } +}; diff --git a/lib/node.js b/lib/node.js new file mode 100644 index 0000000000..e658d2adeb --- /dev/null +++ b/lib/node.js @@ -0,0 +1,529 @@ +const fs = require("node:fs"); +const child_process = require("node:child_process"); +const readline = require("node:readline"); +const os = require("node:os"); +const http = require("node:http"); +const https = require("node:https"); +const path = require("node:path"); +const zlib = require("node:zlib"); +const crypto = require("node:crypto"); +const AdmZip = require("adm-zip"); +const which = require("which"); +const tmp = require("tmp"); +const FormData = require("form-data"); +const { newServer } = require("mock-xmlhttprequest"); + +const runGuida = function (extraEnv, args) { + return new Promise((resolve) => { + const rl = readline.createInterface({ + input: process.stdin, + output: process.stdout, + }); + + let nextCounter = 0, mVarsNextCounter = 0; + let stateT = { imports: {}, types: {}, decls: {} }; + const mVars = {}; + const lockedFiles = {}; + const processes = {}; + + const download = function (method, url) { + const req = https.request(url, { method }, (res) => { + if (res.statusCode >= 200 && res.statusCode < 300) { + let chunks = []; + + res.on("data", (chunk) => { + chunks.push(chunk); + }); + + res.on("end", () => { + const buffer = Buffer.concat(chunks); + const zip = new AdmZip(buffer); + + const sha = crypto.createHash("sha1").update(buffer).digest("hex"); + + const archive = zip.getEntries().map(function (entry) { + return { + eRelativePath: entry.entryName, + eData: zip.readAsText(entry), + }; + }); + + this.send({ sha, archive }); + }); + } else if (res.headers.location) { + download.apply(this, [method, res.headers.location]); + } + }); + + req.on("error", (e) => { + console.error(e); + }); + + req.end(); + }; + + const server = newServer(); + + server.post("getLine", (request) => { + rl.on("line", (value) => { + request.respond(200, null, value); + }); + }); + + server.post("hPutStr", (request) => { + const fd = parseInt(request.requestHeaders.getHeader("fd")); + + fs.write(fd, request.body, (err) => { + if (err) throw err; + request.respond(200); + }); + }); + + server.post("writeString", (request) => { + const path = request.requestHeaders.getHeader("path"); + + fs.writeFile(path, request.body, (err) => { + if (err) throw err; + request.respond(200); + }); + }); + + server.post("read", (request) => { + fs.readFile(request.body, (err, data) => { + if (err) throw err; + request.respond(200, null, data.toString()); + }); + }); + + server.post("readStdin", (request) => { + fs.readFile(0, (err, data) => { + if (err) throw err; + request.respond(200, null, data.toString()); + }); + }); + + server.post("getArchive", (request) => { + download.apply({ + send: ({ sha, archive }) => { + request.respond(200, null, JSON.stringify({ sha, archive })); + } + }, ["GET", request.body]); + }); + + server.post("httpUpload", (request) => { + const { urlStr, headers, parts } = JSON.parse(request.body); + const url = new URL(urlStr); + const client = url.protocol == "https:" ? https : http; + + const form = new FormData(); + + parts.forEach((part) => { + switch (part.type) { + case "FilePart": + form.append(part.name, fs.createReadStream(part.filePath)); + break; + + case "JsonPart": + form.append(part.name, JSON.stringify(part.value), { + contentType: "application/json", + filepath: part.filePath, + }); + break; + + case "StringPart": + form.append(part.name, part.string); + break; + } + }); + + const req = client.request(url, { + method: "POST", + headers: { ...headers, ...form.getHeaders() }, + }); + + form.pipe(req); + + req.on("response", (res) => { + res.on("end", () => { + request.respond(200); + }); + }); + + req.on("error", (err) => { + throw err; + }); + }); + + server.post("withFile", (request) => { + const mode = request.requestHeaders.getHeader("mode"); + + fs.open(request.body, mode, (err, fd) => { + if (err) throw err; + request.respond(200, null, fd); + }); + }); + + server.post("hFileSize", (request) => { + fs.fstat(request.body, (err, stats) => { + if (err) throw err; + request.respond(200, null, stats.size); + }); + }); + + server.post("withCreateProcess", (request) => { + let createProcess = JSON.parse(request.body); + + tmp.file((err, path, fd) => { + if (err) throw err; + + nextCounter += 1; + + fs.createReadStream(path) + .on("data", (chunk) => { + processes[nextCounter].stdin.write(chunk); + }) + .on("close", () => { + processes[nextCounter].stdin.end(); + }); + + processes[nextCounter] = child_process.spawn( + createProcess.cmdspec.cmd, + createProcess.cmdspec.args, + { + stdio: [ + createProcess.stdin, + createProcess.stdout, + createProcess.stderr, + ], + } + ); + + request.respond(200, null, JSON.stringify({ stdinHandle: fd, ph: nextCounter })); + }); + }); + + server.post("hClose", (request) => { + const fd = parseInt(request.body); + fs.close(fd); + request.respond(200); + }); + + server.post("waitForProcess", (request) => { + const ph = parseInt(request.body); + processes[ph].on("exit", (code) => { + request.respond(200, null, code); + }); + }); + + server.post("exitWith", (request) => { + rl.close(); + process.exit(request.body); + }); + + server.post("dirFindExecutable", (request) => { + const path = which.sync(request.body, { nothrow: true }) ?? null; + request.respond(200, null, JSON.stringify(path)); + }); + + server.post("replGetInputLine", (request) => { + rl.question(request.body, (value) => { + request.respond(200, null, JSON.stringify(value)); + }); + }); + + server.post("dirDoesFileExist", (request) => { + fs.stat(request.body, (err, stats) => { + request.respond(200, null, !err && stats.isFile()); + }); + }); + + server.post("dirCreateDirectoryIfMissing", (request) => { + const { createParents, filename } = JSON.parse(request.body); + fs.mkdir(filename, { recursive: createParents }, (_err) => { + request.respond(200); + }); + }); + + server.post("lockFile", (request) => { + const path = request.body; + + if (lockedFiles[path]) { + lockedFiles[path].subscribers.push(request); + } else { + lockedFiles[path] = { subscribers: [] }; + request.respond(200); + } + }); + + server.post("unlockFile", (request) => { + const path = request.body; + + if (lockedFiles[path]) { + const subscriber = lockedFiles[path].subscribers.shift(); + + if (subscriber) { + subscriber.respond(200); + } else { + delete lockedFiles[path]; + } + + request.respond(200); + } else { + console.error(`Could not find locked file "${path}"!`); + rl.close(); + process.exit(255); + } + }); + + server.post("dirGetModificationTime", (request) => { + fs.stat(request.body, (err, stats) => { + if (err) throw err; + request.respond(200, null, parseInt(stats.mtimeMs, 10)); + }); + }); + + server.post("dirDoesDirectoryExist", (request) => { + fs.stat(request.body, (err, stats) => { + request.respond(200, null, !err && stats.isDirectory()); + }); + }); + + server.post("dirCanonicalizePath", (request) => { + request.respond(200, null, path.resolve(request.body)); + }); + + server.post("dirListDirectory", (request) => { + fs.readdir(request.body, { recursive: false }, (err, files) => { + if (err) throw err; + request.respond(200, null, JSON.stringify(files)); + }); + }); + + server.post("binaryDecodeFileOrFail", (request) => { + fs.readFile(request.body, (err, data) => { + if (err) throw err; + request.respond(200, null, data.buffer); + }); + }); + + server.post("write", (request) => { + const path = request.requestHeaders.getHeader("path"); + + fs.writeFile(path, request.body, (err) => { + if (err) throw err; + request.respond(200); + }); + }); + + server.post("dirRemoveFile", (request) => { + fs.unlink(request.body, (err) => { + if (err) throw err; + request.respond(200); + }); + }); + + server.post("dirRemoveDirectoryRecursive", (request) => { + fs.rm(request.body, { recursive: true, force: true }, (err) => { + if (err) throw err; + request.respond(200); + }); + }); + + server.post("dirWithCurrentDirectory", (request) => { + try { + process.chdir(request.body); + request.respond(200); + } catch (err) { + console.error(`chdir: ${err}`); + } + }); + + server.post("envGetArgs", (request) => { + request.respond(200, null, JSON.stringify(process.argv.slice(2))); + }); + + server.post("dirGetCurrentDirectory", (request) => { + request.respond(200, null, process.cwd()); + }); + + server.post("envLookupEnv", (request) => { + const envVar = process.env[request.body] ?? null; + request.respond(200, null, JSON.stringify(envVar)); + }); + + server.post("dirGetAppUserDataDirectory", (request) => { + request.respond(200, null, `${os.homedir()}/.${request.body}`); + }); + + server.post("putStateT", (request) => { + stateT = request.body; + request.respond(200); + }); + + server.post("getStateT", (request) => { + request.respond(200, null, stateT.buffer); + }); + + // MVARS + server.post("newEmptyMVar", (request) => { + mVarsNextCounter += 1; + mVars[mVarsNextCounter] = { subscribers: [], value: undefined }; + request.respond(200, null, mVarsNextCounter); + }); + + server.post("readMVar", (request) => { + const id = request.body; + if (typeof mVars[id].value === "undefined") { + mVars[id].subscribers.push({ action: "read", request }); + } else { + request.respond(200, null, mVars[id].value.buffer); + } + }); + + server.post("takeMVar", (request) => { + const id = request.body; + if (typeof mVars[id].value === "undefined") { + mVars[id].subscribers.push({ action: "take", request }); + } else { + const value = mVars[id].value; + mVars[id].value = undefined; + + if ( + mVars[id].subscribers.length > 0 && + mVars[id].subscribers[0].action === "put" + ) { + const subscriber = mVars[id].subscribers.shift(); + mVars[id].value = subscriber.value; + request.respond(200); + } + + request.respond(200, null, value.buffer); + } + }); + + server.post("putMVar", (request) => { + const id = request.requestHeaders.getHeader("id"); + const value = request.body; + if (typeof mVars[id].value === "undefined") { + mVars[id].value = value; + + mVars[id].subscribers = mVars[id].subscribers.filter((subscriber) => { + if (subscriber.action === "read") { + subscriber.request.respond(200, null, value.buffer); + } + + return subscriber.action !== "read"; + }); + + const subscriber = mVars[id].subscribers.shift(); + + if (subscriber) { + subscriber.request.respond(200, null, value.buffer); + + if (subscriber.action === "take") { + mVars[id].value = undefined; + } + } + + request.respond(200); + } else { + mVars[id].subscribers.push({ action: "put", request, value }); + } + }); + + // NODE + server.post("getArgs", (request) => { + request.respond(200, null, JSON.stringify(args)); + }); + + server.post("exitWithResponse", (request) => { + resolve(JSON.parse(request.body)); + }); + + // NODE.JS SPECIFIC + server.post("nodeGetDirname", (request) => { + request.respond(200, null, __dirname); + }); + + server.post("nodeMathRandom", (request) => { + request.respond(200, null, Math.random()); + }); + + server.setDefaultHandler((request) => { + const url = new URL(request.url); + const client = url.protocol == "https:" ? https : http; + + const req = client.request(url, { + method: request.method, + headers: request.requestHeaders + }, (res) => { + let chunks = []; + + res.on("data", (chunk) => { + chunks.push(chunk); + }); + + res.on("end", () => { + const buffer = Buffer.concat(chunks); + const encoding = res.headers["content-encoding"]; + + if (encoding == "gzip") { + zlib.gunzip(buffer, (err, decoded) => { + if (err) throw err; + request.respond(200, null, decoded && decoded.toString()); + }); + } else if (encoding == "deflate") { + zlib.inflate(buffer, (err, decoded) => { + if (err) throw err; + request.respond(200, null, decoded && decoded.toString()); + }); + } else { + request.respond(200, null, buffer.toString()); + } + }); + }); + + req.on("error", (err) => { + throw err; + }); + + req.end(); + }); + + server.install(); + + const { Elm } = require("./guida.node.min.js"); + + Elm.Node.Main.init(); + }); +} + +module.exports = { + init: async (extraEnv) => { + // await fs.writeFile("root/elm.json", elmJsonContent); + // await fs.createDirectory("root/src"); + + return { + // make: async (content, options) => { + // await fs.writeFile("root/src/Main.guida", content); + + // return await runGuida(extraEnv, { + // command: "make", + // path: "src/Main.guida", + // debug: !!options.debug, + // optimize: !!options.optimize, + // sourcemaps: !!options.sourcemaps + // }); + // }, + format: async (content) => { + return await runGuida(extraEnv, { command: "format", content }); + }, + // install: async (pkg) => { + // return await runGuida(extraEnv, { command: "install", pkg }); + // }, + // uninstall: async (pkg) => { + // return await runGuida(extraEnv, { command: "uninstall", pkg }); + // } + }; + } +}; \ No newline at end of file diff --git a/libraries/test/README.md b/libraries/test/README.md new file mode 100644 index 0000000000..37d8a32c77 --- /dev/null +++ b/libraries/test/README.md @@ -0,0 +1,3 @@ +# node-test-runner + +Copied from [v0.19.1-revision15](https://github.com/rtfeldman/node-test-runner/tree/0.19.1-revision15). \ No newline at end of file diff --git a/libraries/test/src/Console/Text.elm b/libraries/test/src/Console/Text.elm new file mode 100644 index 0000000000..dda8d9f692 --- /dev/null +++ b/libraries/test/src/Console/Text.elm @@ -0,0 +1,217 @@ +module Console.Text exposing + ( Color + , ColorModifier + , Style + , Text + , UseColor(..) + , concat + , dark + , green + , plain + , red + , render + , underline + , yellow + ) + +import Test.Runner.Node.Vendor.Console as Console + + +type Text + = Text { background : Color, foreground : Color, style : Style, modifiers : List ColorModifier } String + | Texts (List Text) + + +type UseColor + = UseColor + | Monochrome + + +type Color + = Default + | Red + | Green + | Yellow + | Black + | Blue + | Magenta + | Cyan + | White + + +type ColorModifier + = Inverted + | Dark + + +type Style + = Normal + | Bold + | Underline + + +render : UseColor -> Text -> String +render useColor txt = + case txt of + Text attrs str -> + case useColor of + UseColor -> + str + |> colorizeBackground attrs.background + |> colorizeForeground attrs.foreground + |> applyModifiers attrs.modifiers + |> applyStyle attrs.style + + Monochrome -> + str + + Texts texts -> + List.map (render useColor) texts + |> String.join "" + + +concat : List Text -> Text +concat = + Texts + + +plain : String -> Text +plain = + Text { foreground = Default, background = Default, style = Normal, modifiers = [] } + + + +-- FOREGROUND COLORS -- + + +red : String -> Text +red = + Text { foreground = Red, background = Default, style = Normal, modifiers = [] } + + +green : String -> Text +green = + Text { foreground = Green, background = Default, style = Normal, modifiers = [] } + + +yellow : String -> Text +yellow = + Text { foreground = Yellow, background = Default, style = Normal, modifiers = [] } + + +dark : Text -> Text +dark txt = + case txt of + Text styles str -> + Text { styles | modifiers = Dark :: styles.modifiers } str + + Texts texts -> + Texts (List.map dark texts) + + + +-- STYLES -- + + +underline : Text -> Text +underline txt = + case txt of + Text styles str -> + Text { styles | style = Underline } str + + Texts texts -> + Texts (List.map dark texts) + + + +-- INTERNAL HELPERS -- + + +colorizeForeground : Color -> String -> String +colorizeForeground color str = + case color of + Default -> + str + + Red -> + Console.red str + + Green -> + Console.green str + + Yellow -> + Console.yellow str + + Black -> + Console.black str + + Blue -> + Console.blue str + + Magenta -> + Console.magenta str + + Cyan -> + Console.cyan str + + White -> + Console.white str + + +colorizeBackground : Color -> String -> String +colorizeBackground color str = + case color of + Default -> + str + + Red -> + Console.bgRed str + + Green -> + Console.bgGreen str + + Yellow -> + Console.bgYellow str + + Black -> + Console.bgBlack str + + Blue -> + Console.bgBlue str + + Magenta -> + Console.bgMagenta str + + Cyan -> + Console.bgCyan str + + White -> + Console.bgWhite str + + +applyStyle : Style -> String -> String +applyStyle style str = + case style of + Normal -> + str + + Bold -> + Console.bold str + + Underline -> + Console.underline str + + +applyModifiers : List ColorModifier -> String -> String +applyModifiers modifiers str = + List.foldl applyModifiersHelp str modifiers + + +applyModifiersHelp : ColorModifier -> String -> String +applyModifiersHelp modifier str = + case modifier of + Inverted -> + Console.colorsInverted str + + Dark -> + Console.dark str diff --git a/libraries/test/src/Test/Reporter/Console.elm b/libraries/test/src/Test/Reporter/Console.elm new file mode 100644 index 0000000000..772ad39a3a --- /dev/null +++ b/libraries/test/src/Test/Reporter/Console.elm @@ -0,0 +1,284 @@ +module Test.Reporter.Console exposing (reportBegin, reportComplete, reportSummary) + +import Console.Text as Text exposing (..) +import Json.Encode as Encode exposing (Value) +import Test.Distribution exposing (DistributionReport) +import Test.Reporter.Console.Format exposing (format) +import Test.Reporter.Console.Format.Color as FormatColor +import Test.Reporter.Console.Format.Monochrome as FormatMonochrome +import Test.Reporter.TestResults as Results exposing (Failure, Outcome(..), SummaryInfo) +import Test.Runner exposing (formatLabels) + + +formatDuration : Float -> String +formatDuration time = + String.fromFloat time ++ " ms" + + +indent : String -> String +indent str = + str + |> String.split "\n" + |> List.map ((++) " ") + |> String.join "\n" + + +pluralize : String -> String -> Int -> String +pluralize singular plural count = + let + suffix = + if count == 1 then + singular + + else + plural + in + String.join " " [ String.fromInt count, suffix ] + + +passedToText : List String -> String -> Text +passedToText labels distributionReport = + Text.concat + [ passedLabelsToText labels + , dark <| plain <| "\n" ++ indent distributionReport ++ "\n\n" + ] + + +passedLabelsToText : List String -> Text +passedLabelsToText = + formatLabels (dark << plain << withChar '↓') (green << withChar '✓') >> Text.concat + + +todosToText : ( List String, String ) -> Text +todosToText ( labels, failure ) = + Text.concat [ todoLabelsToText labels, todoToChalk failure ] + + +todoLabelsToText : List String -> Text +todoLabelsToText = + formatLabels (dark << plain << withChar '↓') (dark << plain << withChar '↓') >> Text.concat + + +todoToChalk : String -> Text +todoToChalk message = + plain ("◦ TODO: " ++ message ++ "\n\n") + + +failuresToText : UseColor -> List String -> List ( Failure, DistributionReport ) -> Text +failuresToText useColor labels failures = + Text.concat (failureLabelsToText labels :: List.map (failureToText useColor) failures) + + +failureLabelsToText : List String -> Text +failureLabelsToText = + formatLabels (dark << plain << withChar '↓') (red << withChar '✗') >> Text.concat + + +failureToText : UseColor -> ( Failure, DistributionReport ) -> Text +failureToText useColor ( { given, description, reason }, distributionReport ) = + let + formatEquality = + case useColor of + Monochrome -> + FormatMonochrome.formatEquality + + UseColor -> + FormatColor.formatEquality + + distributionText = + distributionReportToString distributionReport + |> Maybe.map (\str -> dark (plain ("\n" ++ indent str ++ "\n"))) + + givenText = + given + |> Maybe.map (\str -> dark (plain ("\nGiven " ++ str ++ "\n"))) + + messageText = + plain <| "\n" ++ indent (format formatEquality description reason) ++ "\n\n" + in + [ distributionText + , givenText + , Just messageText + ] + |> List.filterMap identity + |> Text.concat + + +textToValue : UseColor -> Text -> Value +textToValue useColor txt = + txt + |> Text.render useColor + |> Encode.string + + +reportBegin : UseColor -> { r | globs : List String, fuzzRuns : Int, testCount : Int, initialSeed : Int } -> Maybe Value +reportBegin useColor { globs, fuzzRuns, testCount, initialSeed } = + let + prefix = + "Running " + ++ pluralize "test" "tests" testCount + ++ ". To reproduce these results, run: guida test --fuzz " + ++ String.fromInt fuzzRuns + ++ " --seed " + ++ String.fromInt initialSeed + in + Encode.object + [ ( "type", Encode.string "begin" ) + , ( "output" + , (String.join " " (prefix :: globs) ++ "\n") + |> plain + |> textToValue useColor + ) + ] + |> Just + + +getStatus : Outcome -> String +getStatus outcome = + case outcome of + Failed _ -> + "fail" + + Todo _ -> + "todo" + + Passed _ -> + "pass" + + +reportComplete : UseColor -> Results.TestResult -> Value +reportComplete useColor { labels, outcome } = + Encode.object <| + ( "type", Encode.string "complete" ) + :: ( "status", Encode.string (getStatus outcome) ) + :: (case outcome of + Passed distributionReport -> + -- No failures of any kind. + case distributionReportToString distributionReport of + Nothing -> + [] + + Just report -> + [ ( "distributionReport" + , report + |> passedToText labels + |> textToValue useColor + ) + ] + + Failed failures -> + [ ( "failure" + , -- We have non-TODOs still failing; report them, not the TODOs. + failures + |> failuresToText useColor labels + |> textToValue useColor + ) + ] + + Todo str -> + [ ( "todo", Encode.string str ) + , ( "labels", Encode.list Encode.string labels ) + ] + ) + + +summarizeTodos : List ( List String, String ) -> Text +summarizeTodos = + List.map todosToText >> Text.concat + + +reportSummary : UseColor -> SummaryInfo -> Maybe String -> Value +reportSummary useColor { todos, passed, failed, duration } autoFail = + let + headlineResult = + case ( autoFail, failed, List.length todos ) of + ( Nothing, 0, 0 ) -> + Ok "TEST RUN PASSED" + + ( Nothing, 0, 1 ) -> + Err ( yellow, "TEST RUN INCOMPLETE", " because there is 1 TODO remaining" ) + + ( Nothing, 0, numTodos ) -> + Err ( yellow, "TEST RUN INCOMPLETE", " because there are " ++ String.fromInt numTodos ++ " TODOs remaining" ) + + ( Just failure, 0, _ ) -> + Err ( yellow, "TEST RUN INCOMPLETE", " because " ++ failure ) + + _ -> + Err ( red, "TEST RUN FAILED", "" ) + + headline = + case headlineResult of + Ok str -> + underline (green ("\n" ++ str ++ "\n\n")) + + Err ( colorize, str, suffix ) -> + [ underline (colorize ("\n" ++ str)) + , colorize (suffix ++ "\n\n") + ] + |> Text.concat + + todoStats = + -- Print stats for Todos if there are any, + --but don't print details unless only Todos remain + case List.length todos of + 0 -> + plain "" + + numTodos -> + stat "Todo: " (String.fromInt numTodos) + + individualTodos = + if failed > 0 then + plain "" + + else + summarizeTodos (List.reverse todos) + in + Encode.object + [ ( "type", Encode.string "summary" ) + , ( "summary" + , [ headline + , stat "Duration: " (formatDuration duration) + , stat "Passed: " (String.fromInt passed) + , stat "Failed: " (String.fromInt failed) + , todoStats + , individualTodos + ] + |> Text.concat + |> Text.render useColor + |> Encode.string + ) + ] + + +stat : String -> String -> Text +stat label value = + Text.concat + [ dark (plain label) + , plain (value ++ "\n") + ] + + +withChar : Char -> String -> String +withChar icon str = + String.fromChar icon ++ " " ++ str ++ "\n" + + +distributionReportToString : DistributionReport -> Maybe String +distributionReportToString distributionReport = + case distributionReport of + Test.Distribution.NoDistribution -> + Nothing + + Test.Distribution.DistributionToReport r -> + Just (Test.Distribution.distributionReportTable r) + + Test.Distribution.DistributionCheckSucceeded _ -> + {- Not reporting the table although the data is technically there. + We keep the full data dump for the JSON reporter. + -} + Nothing + + Test.Distribution.DistributionCheckFailed r -> + Just (Test.Distribution.distributionReportTable r) diff --git a/libraries/test/src/Test/Reporter/Console/Format.elm b/libraries/test/src/Test/Reporter/Console/Format.elm new file mode 100644 index 0000000000..fc63355665 --- /dev/null +++ b/libraries/test/src/Test/Reporter/Console/Format.elm @@ -0,0 +1,212 @@ +module Test.Reporter.Console.Format exposing (format, highlightEqual) + +import Test.Reporter.Highlightable as Highlightable exposing (Highlightable) +import Test.Runner.Failure exposing (InvalidReason(..), Reason(..)) + + +format : + (List (Highlightable String) -> List (Highlightable String) -> ( String, String )) + -> String + -> Reason + -> String +format formatEquality description reason = + case reason of + Custom -> + description + + Equality expected actual -> + case highlightEqual expected actual of + Nothing -> + verticalBar description expected actual + + Just ( highlightedExpected, highlightedActual ) -> + let + ( formattedExpected, formattedActual ) = + formatEquality highlightedExpected highlightedActual + in + verticalBar description formattedExpected formattedActual + + Comparison first second -> + verticalBar description first second + + TODO -> + description + + Invalid BadDescription -> + if description == "" then + "The empty string is not a valid test description." + + else + "This is an invalid test description: " ++ description + + Invalid _ -> + description + + ListDiff expected actual -> + listDiffToString 0 + description + { expected = expected + , actual = actual + } + { originalExpected = expected + , originalActual = actual + } + + CollectionDiff { expected, actual, extra, missing } -> + let + extraStr = + if List.isEmpty extra then + "" + + else + "\nThese keys are extra: " + ++ (extra |> String.join ", " |> (\d -> "[ " ++ d ++ " ]")) + + missingStr = + if List.isEmpty missing then + "" + + else + "\nThese keys are missing: " + ++ (missing |> String.join ", " |> (\d -> "[ " ++ d ++ " ]")) + in + String.join "" + [ verticalBar description expected actual + , "\n" + , extraStr + , missingStr + ] + + +highlightEqual : String -> String -> Maybe ( List (Highlightable String), List (Highlightable String) ) +highlightEqual expected actual = + if expected == "\"\"" || actual == "\"\"" then + -- Diffing when one is the empty string looks silly. Don't bother. + Nothing + + else if isFloat expected && isFloat actual then + -- Diffing numbers looks silly. Don't bother. + Nothing + + else + let + isHighlighted = + Highlightable.resolve + { fromHighlighted = always True + , fromPlain = always False + } + + edgeCount highlightedString = + let + highlights = + List.map isHighlighted highlightedString + in + highlights + |> List.map2 Tuple.pair (List.drop 1 highlights) + |> List.filter (\( lhs, rhs ) -> lhs /= rhs) + |> List.length + + expectedChars = + String.toList expected + + actualChars = + String.toList actual + + highlightedExpected = + Highlightable.diffLists expectedChars actualChars + |> List.map (Highlightable.map String.fromChar) + + highlightedActual = + Highlightable.diffLists actualChars expectedChars + |> List.map (Highlightable.map String.fromChar) + + plainCharCount = + highlightedExpected + |> List.filter (not << isHighlighted) + |> List.length + in + if edgeCount highlightedActual > plainCharCount || edgeCount highlightedExpected > plainCharCount then + -- Large number of small highlighted blocks. Diff is too messy to be useful. + Nothing + + else + Just + ( highlightedExpected + , highlightedActual + ) + + +isFloat : String -> Bool +isFloat str = + case String.toFloat str of + Just _ -> + True + + Nothing -> + False + + +listDiffToString : + Int + -> String + -> { expected : List String, actual : List String } + -> { originalExpected : List String, originalActual : List String } + -> String +listDiffToString index description { expected, actual } originals = + case ( expected, actual ) of + ( [], [] ) -> + [ "Two lists were unequal previously, yet ended up equal later." + , "This should never happen!" + , "Please report this bug to https://github.com/elm-community/elm-test/issues - and include these lists: " + , "\n" + , String.join ", " originals.originalExpected + , "\n" + , String.join ", " originals.originalActual + ] + |> String.join "" + + ( _ :: _, [] ) -> + verticalBar (description ++ " was shorter than") + (String.join ", " originals.originalExpected) + (String.join ", " originals.originalActual) + + ( [], _ :: _ ) -> + verticalBar (description ++ " was longer than") + (String.join ", " originals.originalExpected) + (String.join ", " originals.originalActual) + + ( firstExpected :: restExpected, firstActual :: restActual ) -> + if firstExpected == firstActual then + -- They're still the same so far; keep going. + listDiffToString (index + 1) + description + { expected = restExpected + , actual = restActual + } + originals + + else + -- We found elements that differ; fail! + String.join "" + [ verticalBar description + (String.join ", " originals.originalExpected) + (String.join ", " originals.originalActual) + , "\n\nThe first diff is at index " + , String.fromInt index + , ": it was `" + , firstActual + , "`, but `" + , firstExpected + , "` was expected." + ] + + +verticalBar : String -> String -> String -> String +verticalBar comparison expected actual = + [ actual + , "╷" + , "│ " ++ comparison + , "╵" + , expected + ] + |> String.join "\n" diff --git a/libraries/test/src/Test/Reporter/Console/Format/Color.elm b/libraries/test/src/Test/Reporter/Console/Format/Color.elm new file mode 100644 index 0000000000..1ef59ae18f --- /dev/null +++ b/libraries/test/src/Test/Reporter/Console/Format/Color.elm @@ -0,0 +1,30 @@ +module Test.Reporter.Console.Format.Color exposing (formatEquality) + +import Test.Reporter.Highlightable as Highlightable exposing (Highlightable) +import Test.Runner.Node.Vendor.Console as Console + + +formatEquality : List (Highlightable String) -> List (Highlightable String) -> ( String, String ) +formatEquality highlightedExpected highlightedActual = + let + formattedExpected = + highlightedExpected + |> List.map fromHighlightable + |> String.join "" + + formattedActual = + highlightedActual + |> List.map fromHighlightable + |> String.join "" + in + ( formattedExpected, formattedActual ) + + +fromHighlightable : Highlightable String -> String +fromHighlightable = + Highlightable.resolve + -- Cyan seems to look readable with both white and black text on top, + -- so it should work with both dark and light console themes + { fromHighlighted = Console.colorsInverted + , fromPlain = identity + } diff --git a/libraries/test/src/Test/Reporter/Console/Format/Monochrome.elm b/libraries/test/src/Test/Reporter/Console/Format/Monochrome.elm new file mode 100644 index 0000000000..0947847f94 --- /dev/null +++ b/libraries/test/src/Test/Reporter/Console/Format/Monochrome.elm @@ -0,0 +1,39 @@ +module Test.Reporter.Console.Format.Monochrome exposing (formatEquality) + +import Test.Reporter.Highlightable as Highlightable exposing (Highlightable) + + +formatEquality : List (Highlightable String) -> List (Highlightable String) -> ( String, String ) +formatEquality highlightedExpected highlightedActual = + let + ( formattedExpected, expectedIndicators ) = + highlightedExpected + |> List.map (fromHighlightable "▲") + |> List.unzip + + ( formattedActual, actualIndicators ) = + highlightedActual + |> List.map (fromHighlightable "▼") + |> List.unzip + + combinedExpected = + String.join "\n" + [ String.join "" formattedExpected + , String.join "" expectedIndicators + ] + + combinedActual = + String.join "\n" + [ String.join "" actualIndicators + , String.join "" formattedActual + ] + in + ( combinedExpected, combinedActual ) + + +fromHighlightable : String -> Highlightable String -> ( String, String ) +fromHighlightable indicator = + Highlightable.resolve + { fromHighlighted = \char -> ( char, indicator ) + , fromPlain = \char -> ( char, " " ) + } diff --git a/libraries/test/src/Test/Reporter/Highlightable.elm b/libraries/test/src/Test/Reporter/Highlightable.elm new file mode 100644 index 0000000000..3b0c9d8a04 --- /dev/null +++ b/libraries/test/src/Test/Reporter/Highlightable.elm @@ -0,0 +1,48 @@ +module Test.Reporter.Highlightable exposing (Highlightable, diffLists, map, resolve) + +import Test.Runner.Node.Vendor.Diff as Diff exposing (Change(..)) + + +type Highlightable a + = Highlighted a + | Plain a + + +resolve : { fromHighlighted : a -> b, fromPlain : a -> b } -> Highlightable a -> b +resolve { fromHighlighted, fromPlain } highlightable = + case highlightable of + Highlighted val -> + fromHighlighted val + + Plain val -> + fromPlain val + + +diffLists : List a -> List a -> List (Highlightable a) +diffLists expected actual = + -- TODO make sure this looks reasonable for multiline strings + Diff.diff expected actual + |> List.concatMap fromDiff + + +map : (a -> b) -> Highlightable a -> Highlightable b +map transform highlightable = + case highlightable of + Highlighted val -> + Highlighted (transform val) + + Plain val -> + Plain (transform val) + + +fromDiff : Change a -> List (Highlightable a) +fromDiff diff = + case diff of + Added _ -> + [] + + Removed char -> + [ Highlighted char ] + + NoChange char -> + [ Plain char ] diff --git a/libraries/test/src/Test/Reporter/JUnit.elm b/libraries/test/src/Test/Reporter/JUnit.elm new file mode 100644 index 0000000000..a28c4824e6 --- /dev/null +++ b/libraries/test/src/Test/Reporter/JUnit.elm @@ -0,0 +1,207 @@ +module Test.Reporter.JUnit exposing (reportBegin, reportComplete, reportSummary) + +import Json.Encode as Encode exposing (Value) +import Test.Distribution exposing (DistributionReport) +import Test.Reporter.TestResults exposing (Failure, Outcome(..), SummaryInfo, TestResult) +import Test.Runner.Failure exposing (InvalidReason(..), Reason(..)) + + +reportBegin : runInfo -> Maybe Value +reportBegin _ = + Nothing + + +encodeDistributionReport : String -> ( String, Value ) +encodeDistributionReport reportText = + ( "system-out", Encode.string reportText ) + + +distributionReportToString : DistributionReport -> Maybe String +distributionReportToString distributionReport = + case distributionReport of + Test.Distribution.NoDistribution -> + Nothing + + Test.Distribution.DistributionToReport r -> + Just (Test.Distribution.distributionReportTable r) + + Test.Distribution.DistributionCheckSucceeded _ -> + {- Not reporting the table to the JUnit stdout (similarly to the + Console reporter) although the data is technically there. + We keep the full data dump for the JSON reporter. + -} + Nothing + + Test.Distribution.DistributionCheckFailed r -> + Just (Test.Distribution.distributionReportTable r) + + +encodeOutcome : Outcome -> List ( String, Value ) +encodeOutcome outcome = + case outcome of + Passed distributionReport -> + distributionReport + |> distributionReportToString + |> Maybe.map (encodeDistributionReport >> List.singleton) + |> Maybe.withDefault [] + + Failed failures -> + let + message = + failures + |> List.map (Tuple.first >> formatFailure) + |> String.join "\n\n\n" + + distributionReports : String + distributionReports = + failures + |> List.filterMap (Tuple.second >> distributionReportToString) + |> String.join "\n\n\n" + + nonemptyDistributionReports : Maybe String + nonemptyDistributionReports = + if String.isEmpty distributionReports then + Nothing + + else + Just distributionReports + in + List.filterMap identity + [ Just (encodeFailureTuple message) + , Maybe.map encodeDistributionReport nonemptyDistributionReports + ] + + Todo message -> + [ encodeFailureTuple ("TODO: " ++ message) ] + + +encodeFailureTuple : String -> ( String, Value ) +encodeFailureTuple message = + ( "failure", Encode.string message ) + + +formatFailure : Failure -> String +formatFailure { given, description, reason } = + let + message = + reasonToString description reason + in + case given of + Just str -> + "Given " ++ str ++ "\n\n" ++ message + + Nothing -> + message + + +formatClassAndName : List String -> ( String, String ) +formatClassAndName labels = + case labels of + head :: rest -> + ( String.join " " (List.reverse rest), head ) + + _ -> + ( "", "" ) + + +encodeDuration : Int -> Value +encodeDuration time = + (toFloat time / 1000) + |> String.fromFloat + |> Encode.string + + +reportComplete : TestResult -> Value +reportComplete { labels, duration, outcome } = + let + ( classname, name ) = + formatClassAndName labels + in + Encode.object + ([ ( "@classname", Encode.string classname ) + , ( "@name", Encode.string name ) + , ( "@time", encodeDuration duration ) + ] + ++ encodeOutcome outcome + ) + + +encodeExtraFailure : String -> Value +encodeExtraFailure _ = + reportComplete { labels = [], duration = 0, outcome = Failed [] } + + +reportSummary : SummaryInfo -> Maybe String -> Value +reportSummary { testCount, duration, failed } autoFail = + let + -- JUnit doesn't have a notion of "everything passed, but you left + -- a Test.only in there, so it's a failure overall." In that case + -- we'll tack on an extra failed test, so the overall suite fails. + -- Another option would be to report it as an Error, but that would + -- make JUnit have different semantics from the other reporters. + -- Also, there wasn't really an error. Nothing broke. + extraFailures = + case ( failed, autoFail ) of + ( 0, Just failure ) -> + [ encodeExtraFailure failure ] + + _ -> + [] + in + Encode.object + [ ( "testsuite" + , Encode.object + [ ( "@name", Encode.string "elm-test" ) + , ( "@package", Encode.string "elm-test" ) + + -- Would be nice to have this provided from elm-package.json of tests + , ( "@tests", Encode.int testCount ) + , ( "@failures", Encode.int failed ) + , ( "@errors", Encode.int 0 ) + , ( "@time", Encode.float duration ) + , ( "testcase", Encode.list identity extraFailures ) + ] + ) + ] + + +reasonToString : String -> Reason -> String +reasonToString description reason = + case reason of + Custom -> + description + + Equality expected actual -> + expected ++ "\n\nwas not equal to\n\n" ++ actual + + Comparison first second -> + first ++ "\n\nfailed when compared with " ++ description ++ " on\n\n" ++ second + + TODO -> + "TODO: " ++ description + + Invalid BadDescription -> + let + explanation = + if description == "" then + "The empty string is not a valid test description." + + else + "This is an invalid test description: " ++ description + in + "Invalid test: " ++ explanation + + Invalid _ -> + "Invalid test: " ++ description + + ListDiff expected actual -> + String.join ", " expected ++ "\n\nhad different elements than\n\n" ++ String.join ", " actual + + CollectionDiff { expected, actual, extra, missing } -> + expected + ++ "\n\nhad different contents than\n\n" + ++ actual + ++ "\n\nthese were extra:\n\n" + ++ String.join "\n" extra + ++ "\n\nthese were missing:\n\n" + ++ String.join "\n" missing diff --git a/libraries/test/src/Test/Reporter/Json.elm b/libraries/test/src/Test/Reporter/Json.elm new file mode 100644 index 0000000000..7636155e67 --- /dev/null +++ b/libraries/test/src/Test/Reporter/Json.elm @@ -0,0 +1,221 @@ +module Test.Reporter.Json exposing (reportBegin, reportComplete, reportSummary) + +import Dict exposing (Dict) +import Json.Encode as Encode exposing (Value) +import Test.Distribution exposing (DistributionReport) +import Test.Reporter.TestResults as TestResults exposing (Failure, Outcome(..), SummaryInfo) +import Test.Runner.Failure exposing (InvalidReason(..), Reason(..)) + + +reportBegin : { globs : List String, paths : List String, fuzzRuns : Int, testCount : Int, initialSeed : Int } -> Maybe Value +reportBegin { globs, paths, fuzzRuns, testCount, initialSeed } = + Encode.object + [ ( "event", Encode.string "runStart" ) + , ( "testCount", Encode.string <| String.fromInt testCount ) + , ( "fuzzRuns", Encode.string <| String.fromInt fuzzRuns ) + , ( "globs", Encode.list Encode.string globs ) + , ( "paths", Encode.list Encode.string paths ) + , ( "initialSeed", Encode.string <| String.fromInt initialSeed ) + ] + |> Just + + +reportComplete : TestResults.TestResult -> Value +reportComplete { duration, labels, outcome } = + Encode.object + [ ( "event", Encode.string "testCompleted" ) + , ( "status", Encode.string (getStatus outcome) ) + , ( "labels", encodeLabels labels ) + , ( "failures", Encode.list identity (encodeFailures outcome) ) + , ( "distributionReports", Encode.list identity (encodeDistributionReports outcome) ) + , ( "duration", Encode.string <| String.fromInt duration ) + ] + + +encodeFailures : Outcome -> List Value +encodeFailures outcome = + case outcome of + Failed failures -> + List.map (Tuple.first >> encodeFailure) failures + + Todo str -> + [ Encode.string str ] + + Passed _ -> + [] + + +encodeDistributionReports : Outcome -> List Value +encodeDistributionReports outcome = + case outcome of + Failed failures -> + List.map (Tuple.second >> encodeDistributionReport) failures + + Todo _ -> + [] + + Passed distributionReport -> + [ encodeDistributionReport distributionReport ] + + +encodeDistributionReport : DistributionReport -> Value +encodeDistributionReport distributionReport = + case distributionReport of + Test.Distribution.NoDistribution -> + Encode.null + |> encodeSumType "NoDistribution" + + Test.Distribution.DistributionToReport r -> + [ ( "distributionCount", encodeDistributionCount r.distributionCount ) + , ( "runsElapsed", Encode.int r.runsElapsed ) + ] + |> Encode.object + |> encodeSumType "DistributionToReport" + + Test.Distribution.DistributionCheckSucceeded r -> + [ ( "distributionCount", encodeDistributionCount r.distributionCount ) + , ( "runsElapsed", Encode.int r.runsElapsed ) + ] + |> Encode.object + |> encodeSumType "DistributionCheckSucceeded" + + Test.Distribution.DistributionCheckFailed r -> + [ ( "distributionCount", encodeDistributionCount r.distributionCount ) + , ( "runsElapsed", Encode.int r.runsElapsed ) + , ( "badLabel", Encode.string r.badLabel ) + , ( "badLabelPercentage", Encode.float r.badLabelPercentage ) + , ( "expectedDistribution", Encode.string r.expectedDistribution ) + ] + |> Encode.object + |> encodeSumType "DistributionCheckFailed" + + +encodeDistributionCount : Dict (List String) Int -> Value +encodeDistributionCount dict = + dict + |> Dict.toList + |> Encode.list + (\( labels, count ) -> + Encode.object + [ ( "labels", Encode.list Encode.string labels ) + , ( "count", Encode.int count ) + ] + ) + + +{-| Algorithm: + + - If any fail, return "fail" + - Otherwise, if any are todo, return "todo" + - Otherwise, return "pass" + +-} +getStatus : Outcome -> String +getStatus outcome = + case outcome of + Failed _ -> + "fail" + + Todo _ -> + "todo" + + Passed _ -> + "pass" + + +encodeLabels : List String -> Value +encodeLabels labels = + List.reverse labels + |> Encode.list Encode.string + + +reportSummary : SummaryInfo -> Maybe String -> Value +reportSummary { duration, passed, failed } autoFail = + Encode.object + [ ( "event", Encode.string "runComplete" ) + , ( "passed", Encode.string <| String.fromInt passed ) + , ( "failed", Encode.string <| String.fromInt failed ) + , ( "duration", Encode.string <| String.fromFloat duration ) + , ( "autoFail" + , autoFail + |> Maybe.map Encode.string + |> Maybe.withDefault Encode.null + ) + ] + + +encodeFailure : Failure -> Value +encodeFailure { given, description, reason } = + Encode.object + [ ( "given", Maybe.withDefault Encode.null (Maybe.map Encode.string given) ) + , ( "message", Encode.string description ) + , ( "reason", encodeReason description reason ) + ] + + +encodeSumType : String -> Value -> Value +encodeSumType sumType data = + Encode.object + [ ( "type", Encode.string sumType ) + , ( "data", data ) + ] + + +encodeReason : String -> Reason -> Value +encodeReason description reason = + case reason of + Custom -> + Encode.string description + |> encodeSumType "Custom" + + Equality expected actual -> + [ ( "expected", Encode.string expected ) + , ( "actual", Encode.string actual ) + , ( "comparison", Encode.string description ) + ] + |> Encode.object + |> encodeSumType "Equality" + + Comparison first second -> + [ ( "first", Encode.string first ) + , ( "second", Encode.string second ) + , ( "comparison", Encode.string description ) + ] + |> Encode.object + |> encodeSumType "Comparison" + + TODO -> + Encode.string description + |> encodeSumType "TODO" + + Invalid BadDescription -> + let + explanation = + if description == "" then + "The empty string is not a valid test description." + + else + "This is an invalid test description: " ++ description + in + Encode.string explanation + |> encodeSumType "Invalid" + + Invalid _ -> + Encode.string description + |> encodeSumType "Invalid" + + ListDiff expected actual -> + [ ( "expected", Encode.list Encode.string expected ) + , ( "actual", Encode.list Encode.string actual ) + ] + |> Encode.object + |> encodeSumType "ListDiff" + + CollectionDiff { expected, actual, extra, missing } -> + [ ( "expected", Encode.string expected ) + , ( "actual", Encode.string actual ) + , ( "extra", Encode.list Encode.string extra ) + , ( "missing", Encode.list Encode.string missing ) + ] + |> Encode.object + |> encodeSumType "CollectionDiff" diff --git a/libraries/test/src/Test/Reporter/Reporter.elm b/libraries/test/src/Test/Reporter/Reporter.elm new file mode 100644 index 0000000000..51aeb0231e --- /dev/null +++ b/libraries/test/src/Test/Reporter/Reporter.elm @@ -0,0 +1,53 @@ +module Test.Reporter.Reporter exposing (Report(..), RunInfo, TestReporter, createReporter) + +import Console.Text exposing (UseColor) +import Json.Encode exposing (Value) +import Test.Reporter.Console as ConsoleReporter +import Test.Reporter.JUnit as JUnitReporter +import Test.Reporter.Json as JsonReporter +import Test.Reporter.TestResults exposing (SummaryInfo, TestResult) + + +type Report + = ConsoleReport UseColor + | JsonReport + | JUnitReport + + +type alias TestReporter = + { format : String + , reportBegin : RunInfo -> Maybe Value + , reportComplete : TestResult -> Value + , reportSummary : SummaryInfo -> Maybe String -> Value + } + + +type alias RunInfo = + { globs : List String + , paths : List String + , fuzzRuns : Int + , testCount : Int + , initialSeed : Int + } + + +createReporter : Report -> TestReporter +createReporter report = + case report of + JsonReport -> + TestReporter "JSON" + JsonReporter.reportBegin + JsonReporter.reportComplete + JsonReporter.reportSummary + + ConsoleReport useColor -> + TestReporter "CHALK" + (ConsoleReporter.reportBegin useColor) + (ConsoleReporter.reportComplete useColor) + (ConsoleReporter.reportSummary useColor) + + JUnitReport -> + TestReporter "JUNIT" + JUnitReporter.reportBegin + JUnitReporter.reportComplete + JUnitReporter.reportSummary diff --git a/libraries/test/src/Test/Reporter/TestResults.elm b/libraries/test/src/Test/Reporter/TestResults.elm new file mode 100644 index 0000000000..eeb241c3fc --- /dev/null +++ b/libraries/test/src/Test/Reporter/TestResults.elm @@ -0,0 +1,126 @@ +module Test.Reporter.TestResults exposing + ( Failure + , Outcome(..) + , SummaryInfo + , TestResult + , isFailure + , outcomesFromExpectations + ) + +import Expect exposing (Expectation) +import Test.Distribution exposing (DistributionReport) +import Test.Runner +import Test.Runner.Failure exposing (Reason) + + +type Outcome + = Passed DistributionReport + | Todo String + | Failed (List ( Failure, DistributionReport )) + + +type alias TestResult = + { labels : List String + , outcome : Outcome + , duration : Int -- in milliseconds + } + + +type alias SummaryInfo = + { testCount : Int + , passed : Int + , failed : Int + , todos : List ( List String, String ) + , duration : Float + } + + +type alias Failure = + { given : Maybe String + , description : String + , reason : Reason + } + + +isFailure : Outcome -> Bool +isFailure outcome = + case outcome of + Failed _ -> + True + + _ -> + False + + +outcomesFromExpectations : List Expectation -> List Outcome +outcomesFromExpectations expectations = + case expectations of + expectation :: [] -> + -- Most often we'll get exactly 1 pass, so try that case first! + case Test.Runner.getFailureReason expectation of + Nothing -> + [ Passed (Test.Runner.getDistributionReport expectation) ] + + Just failure -> + if Test.Runner.isTodo expectation then + [ Todo failure.description ] + + else + [ Failed + [ ( failure, Test.Runner.getDistributionReport expectation ) ] + ] + + _ :: _ -> + let + builder = + List.foldl outcomesFromExpectationsHelp + { passes = [], todos = [], failures = [] } + expectations + + failuresList = + case builder.failures of + [] -> + [] + + failures -> + [ Failed failures ] + in + List.concat + [ List.map Passed builder.passes + , List.map Todo builder.todos + , failuresList + ] + + [] -> + [] + + +type alias OutcomeBuilder = + { passes : List DistributionReport + , todos : List String + , failures : List ( Failure, DistributionReport ) + } + + +outcomesFromExpectationsHelp : Expectation -> OutcomeBuilder -> OutcomeBuilder +outcomesFromExpectationsHelp expectation builder = + case Test.Runner.getFailureReason expectation of + Just failure -> + if Test.Runner.isTodo expectation then + { builder | todos = failure.description :: builder.todos } + + else + { builder + | failures = + ( failure + , Test.Runner.getDistributionReport expectation + ) + :: builder.failures + } + + Nothing -> + { builder + | passes = + Test.Runner.getDistributionReport expectation + :: builder.passes + } diff --git a/libraries/test/src/Test/Runner/JsMessage.elm b/libraries/test/src/Test/Runner/JsMessage.elm new file mode 100644 index 0000000000..0fa71180b3 --- /dev/null +++ b/libraries/test/src/Test/Runner/JsMessage.elm @@ -0,0 +1,38 @@ +module Test.Runner.JsMessage exposing (JsMessage(..), decoder) + +import Json.Decode as Decode exposing (Decoder) + + +type JsMessage + = Test Int + | Summary Float Int (List ( List String, String )) + + +decoder : Decoder JsMessage +decoder = + Decode.field "type" Decode.string + |> Decode.andThen decodeMessageFromType + + +decodeMessageFromType : String -> Decoder JsMessage +decodeMessageFromType messageType = + case messageType of + "TEST" -> + Decode.field "index" Decode.int + |> Decode.map Test + + "SUMMARY" -> + Decode.map3 Summary + (Decode.field "duration" Decode.float) + (Decode.field "failures" Decode.int) + (Decode.field "todos" (Decode.list todoDecoder)) + + _ -> + Decode.fail ("Unrecognized message type: " ++ messageType) + + +todoDecoder : Decoder ( List String, String ) +todoDecoder = + Decode.map2 (\a b -> ( a, b )) + (Decode.field "labels" (Decode.list Decode.string)) + (Decode.field "todo" Decode.string) diff --git a/libraries/test/src/Test/Runner/Node.elm b/libraries/test/src/Test/Runner/Node.elm new file mode 100644 index 0000000000..2e9f7cd888 --- /dev/null +++ b/libraries/test/src/Test/Runner/Node.elm @@ -0,0 +1,440 @@ +port module Test.Runner.Node exposing (check, run, TestProgram) + +{-| + + +# Node Runner + +Runs a test and outputs its results to the console. Exit code is 0 if tests +passed and 2 if any failed. Returns 1 if something went wrong. + +@docs check, run, TestProgram + +-} + +import Dict exposing (Dict) +import Json.Decode as Decode +import Json.Encode as Encode +import Platform +import Random +import Task +import Test exposing (Test) +import Test.Reporter.Reporter exposing (Report, RunInfo, TestReporter, createReporter) +import Test.Reporter.TestResults exposing (Outcome, TestResult, isFailure, outcomesFromExpectations) +import Test.Runner exposing (Runner, SeededRunners(..)) +import Test.Runner.JsMessage as JsMessage exposing (JsMessage(..)) +import Time exposing (Posix) + + + +-- TYPES + + +type alias TestId = + Int + + +type alias InitArgs = + { initialSeed : Int + , processes : Int + , globs : List String + , paths : List String + , fuzzRuns : Int + , runners : SeededRunners + , report : Report + } + + +type alias RunnerOptions = + { seed : Int + , runs : Int + , report : Report + , globs : List String + , paths : List String + , processes : Int + } + + +type alias Model = + { available : Dict TestId Runner + , runInfo : RunInfo + , testReporter : TestReporter + , results : List ( TestId, TestResult ) + , processes : Int + , nextTestToRun : TestId + , autoFail : Maybe String + } + + +{-| A program which will run tests and report their results. +-} +type alias TestProgram = + Platform.Program Int Model Msg + + +type Msg + = Receive Decode.Value + | Dispatch Posix + | Complete (List String) (List Outcome) Posix Posix + + +{-| The port names are prefixed to reduce the likelihood of the project +having a port with the same name, which is a compile error. +-} +port elmTestPort__send : String -> Cmd msg + + +port elmTestPort__receive : (Decode.Value -> msg) -> Sub msg + + +dispatch : Model -> Posix -> Cmd Msg +dispatch model startTime = + case Dict.get model.nextTestToRun model.available of + Nothing -> + -- We're finished! Nothing left to run. + sendResults True model.testReporter model.results + + Just config -> + let + outcomes = + outcomesFromExpectations (config.run ()) + in + Time.now + |> Task.perform (Complete config.labels outcomes startTime) + + +update : Msg -> Model -> ( Model, Cmd Msg ) +update msg ({ testReporter } as model) = + case msg of + Receive val -> + case Decode.decodeValue JsMessage.decoder val of + Ok (Summary duration failed todos) -> + let + testCount = + model.runInfo.testCount + + summaryInfo = + { testCount = testCount + , passed = testCount - failed - List.length todos + , failed = failed + , todos = todos + , duration = duration + } + + summary = + testReporter.reportSummary summaryInfo model.autoFail + + exitCode = + if failed > 0 then + 2 + + else if model.autoFail == Nothing && List.isEmpty todos then + 0 + + else + 3 + + cmd = + Encode.object + [ ( "type", Encode.string "SUMMARY" ) + , ( "exitCode", Encode.int exitCode ) + , ( "message", summary ) + ] + |> Encode.encode 0 + |> elmTestPort__send + in + ( model, cmd ) + + Ok (Test index) -> + let + cmd = + Task.perform Dispatch Time.now + in + if index == -1 then + ( { model | nextTestToRun = index + model.processes } + , Cmd.batch [ cmd, sendBegin model ] + ) + + else + ( { model | nextTestToRun = index }, cmd ) + + Err err -> + let + cmd = + Encode.object + [ ( "type", Encode.string "ERROR" ) + , ( "message", Encode.string (Decode.errorToString err) ) + ] + |> Encode.encode 0 + |> elmTestPort__send + in + ( model, cmd ) + + Dispatch startTime -> + ( model, dispatch model startTime ) + + Complete labels outcomes startTime endTime -> + let + duration = + Time.posixToMillis endTime - Time.posixToMillis startTime + + prependOutcome outcome rest = + ( model.nextTestToRun + , { labels = labels, outcome = outcome, duration = duration } + ) + :: rest + + results = + List.foldl prependOutcome model.results outcomes + + nextTestToRun = + model.nextTestToRun + model.processes + + isFinished = + nextTestToRun >= model.runInfo.testCount + in + if isFinished || List.any isFailure outcomes then + let + cmd = + sendResults isFinished testReporter results + in + if isFinished then + -- Don't bother updating the model, since we're done + ( model, cmd ) + + else + -- Clear out the results, now that we've flushed them. + ( { model | nextTestToRun = nextTestToRun, results = [] } + , Cmd.batch + [ cmd + , Task.perform Dispatch Time.now + ] + ) + + else + ( { model | nextTestToRun = nextTestToRun, results = results } + , Task.perform Dispatch Time.now + ) + + +sendResults : Bool -> TestReporter -> List ( TestId, TestResult ) -> Cmd msg +sendResults isFinished testReporter results = + let + typeStr = + if isFinished then + "FINISHED" + + else + "RESULTS" + + addToKeyValues ( testId, result ) list = + -- These are coming in in reverse order. Doing a foldl with :: + -- means we reverse the list again, while also doing the conversion! + ( String.fromInt testId, testReporter.reportComplete result ) :: list + in + Encode.object + [ ( "type", Encode.string typeStr ) + , ( "results" + , results + |> List.foldl addToKeyValues [] + |> Encode.object + ) + ] + |> Encode.encode 0 + |> elmTestPort__send + + +sendBegin : Model -> Cmd msg +sendBegin model = + let + baseFields = + [ ( "type", Encode.string "BEGIN" ) + , ( "testCount", Encode.int model.runInfo.testCount ) + ] + + extraFields = + case model.testReporter.reportBegin model.runInfo of + Just report -> + [ ( "message", report ) ] + + Nothing -> + [] + in + Encode.object (baseFields ++ extraFields) + |> Encode.encode 0 + |> elmTestPort__send + + +init : InitArgs -> Int -> ( Model, Cmd Msg ) +init { processes, globs, paths, fuzzRuns, initialSeed, report, runners } _ = + let + { indexedRunners, autoFail } = + case runners of + Plain runnerList -> + { indexedRunners = List.indexedMap (\a b -> ( a, b )) runnerList + , autoFail = Nothing + } + + Only runnerList -> + { indexedRunners = List.indexedMap (\a b -> ( a, b )) runnerList + , autoFail = Just "Test.only was used" + } + + Skipping runnerList -> + { indexedRunners = List.indexedMap (\a b -> ( a, b )) runnerList + , autoFail = Just "Test.skip was used" + } + + Invalid str -> + { indexedRunners = [] + , autoFail = Just str + } + + testCount = + List.length indexedRunners + + testReporter = + createReporter report + + model = + { available = Dict.fromList indexedRunners + , runInfo = + { testCount = testCount + , globs = globs + , paths = paths + , fuzzRuns = fuzzRuns + , initialSeed = initialSeed + } + , processes = processes + , nextTestToRun = 0 + , results = [] + , testReporter = testReporter + , autoFail = autoFail + } + in + ( model, Cmd.none ) + + +failInit : String -> Report -> Int -> ( Model, Cmd Msg ) +failInit message report _ = + let + model = + { available = Dict.empty + , runInfo = + { testCount = 0 + , globs = [] + , paths = [] + , fuzzRuns = 0 + , initialSeed = 0 + } + , processes = 0 + , nextTestToRun = 0 + , results = [] + , testReporter = createReporter report + , autoFail = Nothing + } + + cmd = + Encode.object + [ ( "type", Encode.string "SUMMARY" ) + , ( "exitCode", Encode.int 1 ) + , ( "message", Encode.string message ) + ] + |> Encode.encode 0 + |> elmTestPort__send + in + ( model, cmd ) + + +{-| The implementation of this function will be replaced in the generated JS +with a version that returns `Just value` if `value` is a `Test`, otherwise `Nothing`. + +If you rename or change this function you also need to update the regex that looks for it. + +-} +check : a -> Maybe Test +check = + checkHelperReplaceMe___ + + +checkHelperReplaceMe___ : a -> b +checkHelperReplaceMe___ _ = + Debug.todo "The regex for replacing this Debug.todo with some real code must have failed since you see this message!\n\nPlease report this bug: https://github.com/rtfeldman/node-test-runner/issues/new\n" + + +{-| Run the tests. +-} +run : RunnerOptions -> List ( String, List (Maybe Test) ) -> Program Int Model Msg +run { runs, seed, report, globs, paths, processes } possiblyTests = + let + tests = + possiblyTests + |> List.filterMap + (\( moduleName, maybeModuleTests ) -> + let + moduleTests = + List.filterMap identity maybeModuleTests + in + if List.isEmpty moduleTests then + Nothing + + else + Just (Test.describe moduleName moduleTests) + ) + in + if List.isEmpty tests then + Platform.worker + { init = failInit (noTestsFoundError globs) report + , update = \_ model -> ( model, Cmd.none ) + , subscriptions = \_ -> Sub.none + } + + else + let + runners = + Test.Runner.fromTest runs (Random.initialSeed seed) (Test.concat tests) + + wrappedInit = + init + { initialSeed = seed + , processes = processes + , globs = globs + , paths = paths + , fuzzRuns = runs + , runners = runners + , report = report + } + in + Platform.worker + { init = wrappedInit + , update = update + , subscriptions = \_ -> elmTestPort__receive Receive + } + + +noTestsFoundError : List String -> String +noTestsFoundError globs = + if List.isEmpty globs then + """ +No exposed values of type Test found in the tests/ directory. + +Are there tests in any .elm file in the tests/ directory? +If not – add some! +If there are – are they exposed? + """ + |> String.trim + + else + """ +No exposed values of type Test found in files matching: + +%globs + +Are the above patterns correct? Maybe try running elm-test with no arguments? + +Are there tests in any of the matched files? +If not – add some! +If there are – are they exposed? + """ + |> String.trim + |> String.replace "%globs" (String.join "\n" globs) diff --git a/libraries/test/src/Test/Runner/Node/Vendor/Console.elm b/libraries/test/src/Test/Runner/Node/Vendor/Console.elm new file mode 100644 index 0000000000..631afbd0b5 --- /dev/null +++ b/libraries/test/src/Test/Runner/Node/Vendor/Console.elm @@ -0,0 +1,230 @@ +module Test.Runner.Node.Vendor.Console exposing (bgBlack, bgBlue, bgCyan, bgGreen, bgMagenta, bgRed, bgWhite, bgYellow, black, blue, bold, colorsInverted, cyan, dark, green, magenta, red, underline, white, yellow) + +{-| -} + +-- NOTE: This is copy/pasted from https://github.com/rtfeldman/console-print +-- It's inlined to avoid having to call elm-package install on the end user's +-- system - the approach this library took prior to +-- commit 19047f01d460739bfe7f16466bc60b41430a8f09 - because it assumes +-- the end user has the correct elm-package on their PATH, which is not a +-- safe assumption. +-- +-- License: +{- + BSD 3-Clause License + + Copyright (c) 2017, Richard Feldman + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + + * Neither the name of the copyright holder nor the names of its + contributors may be used to endorse or promote products derived from + this software without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE + DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE + FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR + SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER + CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, + OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE + OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +-} + + +{-| Make the text darker. + +This can be used with other text modifiers, such as color. + + import Console exposing (dark, green) + + + -- "Hello, dark green world!" with "dark green" in dark green + greeting : String + greeting = + "Hello, " ++ (dark << green) "dark green" ++ " world!" + +Not all terminals support this. + +-} +dark : String -> String +dark str = + String.join "" [ "\u{001B}[2m", str, "\u{001B}[22m" ] + + +{-| Make the text bold. + +This can be used with other text modifiers, such as color. + + import Console exposing (blue, bold) + + + -- "Hello, bold blue world!" with "bold blue" in bold and blue + greeting : String + greeting = + "Hello, " ++ (bold << blue) "bold blue" ++ " world!" + +Some terminals implement this as a color change rather than a boldness change. + +-} +bold : String -> String +bold str = + String.join "" [ "\u{001B}[1m", str, "\u{001B}[22m" ] + + +{-| Make the text underlined. + +This can be used with other text modifiers, such as color. + + import Console exposing (underline) + + + -- "This will look like a hyperlink" with "hyperlink" underlined + example : String + example = + "This will look like a " ++ underline "hyperlink" + +Not all terminals support this. + +-} +underline : String -> String +underline str = + String.join "" [ "\u{001B}[4m", str, "\u{001B}[24m" ] + + +{-| Invert the foreground and background colors from what they would otherwise be. +-} +colorsInverted : String -> String +colorsInverted str = + String.join "" [ "\u{001B}[7m", str, "\u{001B}[27m" ] + + + +-- Foreground Colors + + +{-| Make the foreground text black. +-} +black : String -> String +black str = + String.join "" [ "\u{001B}[30m", str, "\u{001B}[39m" ] + + +{-| Make the foreground text red. +-} +red : String -> String +red str = + String.join "" [ "\u{001B}[31m", str, "\u{001B}[39m" ] + + +{-| Make the foreground text green. +-} +green : String -> String +green str = + String.join "" [ "\u{001B}[32m", str, "\u{001B}[39m" ] + + +{-| Make the foreground text yellow. +-} +yellow : String -> String +yellow str = + String.join "" [ "\u{001B}[33m", str, "\u{001B}[39m" ] + + +{-| Make the foreground text blue. +-} +blue : String -> String +blue str = + String.join "" [ "\u{001B}[34m", str, "\u{001B}[39m" ] + + +{-| Make the foreground text magenta. +-} +magenta : String -> String +magenta str = + String.join "" [ "\u{001B}[35m", str, "\u{001B}[39m" ] + + +{-| Make the foreground text cyan. +-} +cyan : String -> String +cyan str = + String.join "" [ "\u{001B}[36m", str, "\u{001B}[39m" ] + + +{-| Make the foreground text white. +-} +white : String -> String +white str = + String.join "" [ "\u{001B}[37m", str, "\u{001B}[39m" ] + + + +-- Background Colors + + +{-| Make the background black. +-} +bgBlack : String -> String +bgBlack str = + String.join "" [ "\u{001B}[40m", str, "\u{001B}[49m" ] + + +{-| Make the background red. +-} +bgRed : String -> String +bgRed str = + String.join "" [ "\u{001B}[41m", str, "\u{001B}[49m" ] + + +{-| Make the background green. +-} +bgGreen : String -> String +bgGreen str = + String.join "" [ "\u{001B}[42m", str, "\u{001B}[49m" ] + + +{-| Make the background yellow. +-} +bgYellow : String -> String +bgYellow str = + String.join "" [ "\u{001B}[43m", str, "\u{001B}[49m" ] + + +{-| Make the background blue. +-} +bgBlue : String -> String +bgBlue str = + String.join "" [ "\u{001B}[44m", str, "\u{001B}[49m" ] + + +{-| Make the background magenta. +-} +bgMagenta : String -> String +bgMagenta str = + String.join "" [ "\u{001B}[45m", str, "\u{001B}[49m" ] + + +{-| Make the background cyan. +-} +bgCyan : String -> String +bgCyan str = + String.join "" [ "\u{001B}[46m", str, "\u{001B}[49m" ] + + +{-| Make the background white. +-} +bgWhite : String -> String +bgWhite str = + String.join "" [ "\u{001B}[47m", str, "\u{001B}[49m" ] diff --git a/libraries/test/src/Test/Runner/Node/Vendor/Diff.elm b/libraries/test/src/Test/Runner/Node/Vendor/Diff.elm new file mode 100644 index 0000000000..6f59e0d0ac --- /dev/null +++ b/libraries/test/src/Test/Runner/Node/Vendor/Diff.elm @@ -0,0 +1,326 @@ +module Test.Runner.Node.Vendor.Diff exposing + ( Change(..) + , diff + ) + +{-| Compares two list and returns how they have changed. +Each function internally uses Wu's [O(NP) algorithm](http://myerslab.mpi-cbg.de/wp-content/uploads/2014/06/np_diff.pdf). + + +# Types + +@docs Change + + +# Diffing + +@docs diff, diffLines + +-} + +-- NOTE: This is copy/pasted from https://github.com/jinjor/elm-diff +-- It's inlined to avoid having to call elm-package install on the end user's +-- system - the approach this library took prior to +-- commit 19047f01d460739bfe7f16466bc60b41430a8f09 - because it assumes +-- the end user has the correct elm-package on their PATH, which is not a +-- safe assumption. +-- +-- License: +{- + Copyright (c) 2016, Yosuke Torii + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + + * Neither the name of elm-diff nor the names of its + contributors may be used to endorse or promote products derived from + this software without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE + DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE + FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR + SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER + CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, + OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE + OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +-} + +import Array exposing (Array) + + +{-| This describes how each line has changed and also contains its value. +-} +type Change a + = Added a + | Removed a + | NoChange a + + +type StepResult + = Continue (Array (List ( Int, Int ))) + | Found (List ( Int, Int )) + + +type BugReport + = CannotGetA Int + | CannotGetB Int + | UnexpectedPath ( Int, Int ) (List ( Int, Int )) + + +{-| Compares general lists. + + diff [ 1, 3 ] [ 2, 3 ] == [ Removed 1, Added 2, NoChange 3 ] -- True + +-} +diff : List a -> List a -> List (Change a) +diff a b = + case testDiff a b of + Ok changes -> + changes + + Err _ -> + [] + + +{-| Test the algolithm itself. +If it returns Err, it should be a bug. +-} +testDiff : List a -> List a -> Result BugReport (List (Change a)) +testDiff a b = + let + arrA = + Array.fromList a + + arrB = + Array.fromList b + + m = + Array.length arrA + + n = + Array.length arrB + + -- Elm's Array doesn't allow null element, + -- so we'll use shifted index to access source. + getA = + \x -> Array.get (x - 1) arrA + + getB = + \y -> Array.get (y - 1) arrB + + path = + -- Is there any case ond is needed? + -- ond getA getB m n + onp getA getB m n + in + makeChanges getA getB path + + +makeChanges : + (Int -> Maybe a) + -> (Int -> Maybe a) + -> List ( Int, Int ) + -> Result BugReport (List (Change a)) +makeChanges getA getB path = + case path of + [] -> + Ok [] + + latest :: tail -> + makeChangesHelp [] getA getB latest tail + + +makeChangesHelp : + List (Change a) + -> (Int -> Maybe a) + -> (Int -> Maybe a) + -> ( Int, Int ) + -> List ( Int, Int ) + -> Result BugReport (List (Change a)) +makeChangesHelp changes getA getB ( x, y ) path = + case path of + [] -> + Ok changes + + ( prevX, prevY ) :: tail -> + let + change = + if x - 1 == prevX && y - 1 == prevY then + case getA x of + Just a -> + Ok (NoChange a) + + Nothing -> + Err (CannotGetA x) + + else if x == prevX then + case getB y of + Just b -> + Ok (Added b) + + Nothing -> + Err (CannotGetB y) + + else if y == prevY then + case getA x of + Just a -> + Ok (Removed a) + + Nothing -> + Err (CannotGetA x) + + else + Err (UnexpectedPath ( x, y ) path) + in + case change of + Err err -> + Err err + + Ok c -> + makeChangesHelp (c :: changes) getA getB ( prevX, prevY ) tail + + + +-- Wu's O(NP) algorithm (http://myerslab.mpi-cbg.de/wp-content/uploads/2014/06/np_diff.pdf) + + +onp : (Int -> Maybe a) -> (Int -> Maybe a) -> Int -> Int -> List ( Int, Int ) +onp getA getB m n = + let + v = + Array.initialize (m + n + 1) (always []) + + delta = + n - m + in + onpLoopP (snake getA getB) delta m 0 v + + +onpLoopP : + (Int -> Int -> List ( Int, Int ) -> ( List ( Int, Int ), Bool )) + -> Int + -> Int + -> Int + -> Array (List ( Int, Int )) + -> List ( Int, Int ) +onpLoopP snake_ delta offset p v = + let + ks = + if delta > 0 then + List.reverse (List.range (delta + 1) (delta + p)) + ++ List.range -p delta + + else + List.reverse (List.range (delta + 1) p) + ++ List.range (-p + delta) delta + in + case onpLoopK snake_ offset ks v of + Found path -> + path + + Continue v_ -> + onpLoopP snake_ delta offset (p + 1) v_ + + +onpLoopK : + (Int -> Int -> List ( Int, Int ) -> ( List ( Int, Int ), Bool )) + -> Int + -> List Int + -> Array (List ( Int, Int )) + -> StepResult +onpLoopK snake_ offset ks v = + case ks of + [] -> + Continue v + + k :: ks_ -> + case step snake_ offset k v of + Found path -> + Found path + + Continue v_ -> + onpLoopK snake_ offset ks_ v_ + + +step : + (Int -> Int -> List ( Int, Int ) -> ( List ( Int, Int ), Bool )) + -> Int + -> Int + -> Array (List ( Int, Int )) + -> StepResult +step snake_ offset k v = + let + fromLeft = + Maybe.withDefault [] (Array.get (k - 1 + offset) v) + + fromTop = + Maybe.withDefault [] (Array.get (k + 1 + offset) v) + + ( path, ( x, y ) ) = + case ( fromLeft, fromTop ) of + ( [], [] ) -> + ( [], ( 0, 0 ) ) + + ( [], ( topX, topY ) :: _ ) -> + ( fromTop, ( topX + 1, topY ) ) + + ( ( leftX, leftY ) :: _, [] ) -> + ( fromLeft, ( leftX, leftY + 1 ) ) + + ( ( leftX, leftY ) :: _, ( topX, topY ) :: _ ) -> + -- this implies "remove" comes always earlier than "add" + if leftY + 1 >= topY then + ( fromLeft, ( leftX, leftY + 1 ) ) + + else + ( fromTop, ( topX + 1, topY ) ) + + ( newPath, goal ) = + snake_ (x + 1) (y + 1) (( x, y ) :: path) + in + if goal then + Found newPath + + else + Continue (Array.set (k + offset) newPath v) + + +snake : + (Int -> Maybe a) + -> (Int -> Maybe a) + -> Int + -> Int + -> List ( Int, Int ) + -> ( List ( Int, Int ), Bool ) +snake getA getB nextX nextY path = + case ( getA nextX, getB nextY ) of + ( Just a, Just b ) -> + if a == b then + snake + getA + getB + (nextX + 1) + (nextY + 1) + (( nextX, nextY ) :: path) + + else + ( path, False ) + + -- reached bottom-right corner + ( Nothing, Nothing ) -> + ( path, True ) + + _ -> + ( path, False ) diff --git a/package-lock.json b/package-lock.json new file mode 100644 index 0000000000..4672bcb189 --- /dev/null +++ b/package-lock.json @@ -0,0 +1,8135 @@ +{ + "name": "guida", + "version": "1.0.0-alpha", + "lockfileVersion": 3, + "requires": true, + "packages": { + "": { + "name": "guida", + "version": "1.0.0-alpha", + "license": "BSD-3-Clause", + "dependencies": { + "adm-zip": "^0.5.16", + "form-data": "^4.0.2", + "indexeddb-fs": "^2.1.5", + "jszip": "^3.10.1", + "mock-xmlhttprequest": "^8.4.1", + "tmp": "^0.2.3", + "which": "^5.0.0" + }, + "bin": { + "guida": "bin/index.js" + }, + "devDependencies": { + "@eslint/js": "^9.23.0", + "elm": "^0.19.1-6", + "elm-format": "^0.8.7", + "elm-review": "^2.13.2", + "elm-test": "^0.19.1-revision15", + "eslint": "^9.23.0", + "eslint-plugin-jest": "^28.11.0", + "globals": "^16.0.0", + "guida": "^0.3.0-alpha", + "jest": "^29.7.0", + "npm-run-all": "^4.1.5", + "onchange": "^7.1.0", + "uglify-js": "^3.19.3" + } + }, + "node_modules/@ampproject/remapping": { + "version": "2.3.0", + "resolved": "https://registry.npmjs.org/@ampproject/remapping/-/remapping-2.3.0.tgz", + "integrity": "sha512-30iZtAPgz+LTIYoeivqYo853f02jBYSd5uGnGpkFV0M3xOt9aN73erkgYAmZU43x4VfqcnLxW9Kpg3R5LC4YYw==", + "dev": true, + "license": "Apache-2.0", + "dependencies": { + "@jridgewell/gen-mapping": "^0.3.5", + "@jridgewell/trace-mapping": "^0.3.24" + }, + "engines": { + "node": ">=6.0.0" + } + }, + "node_modules/@avh4/elm-format-darwin-arm64": { + "version": "0.8.7-2", + "resolved": "https://registry.npmjs.org/@avh4/elm-format-darwin-arm64/-/elm-format-darwin-arm64-0.8.7-2.tgz", + "integrity": "sha512-F5JD44mJ3KX960J5GkXMfh1/dtkXuPcQpX2EToHQKjLTZUfnhZ++ytQQt0gAvrJ0bzoOvhNzjNjUHDA1ruTVbg==", + "cpu": [ + "arm64" + ], + "dev": true, + "license": "BSD-3-Clause", + "optional": true, + "os": [ + "darwin" + ] + }, + "node_modules/@avh4/elm-format-darwin-x64": { + "version": "0.8.7-2", + "resolved": "https://registry.npmjs.org/@avh4/elm-format-darwin-x64/-/elm-format-darwin-x64-0.8.7-2.tgz", + "integrity": "sha512-4pfF1cl0KyTion+7Mg4XKM3yi4Yc7vP76Kt/DotLVGJOSag4ISGic1og2mt8RZZ7XArybBmHNyYkiUbe/cEiCw==", + "cpu": [ + "x64" + ], + "dev": true, + "license": "BSD-3-Clause", + "optional": true, + "os": [ + "darwin" + ] + }, + "node_modules/@avh4/elm-format-linux-arm64": { + "version": "0.8.7-2", + "resolved": "https://registry.npmjs.org/@avh4/elm-format-linux-arm64/-/elm-format-linux-arm64-0.8.7-2.tgz", + "integrity": "sha512-WkVmuce2zU6s9dupHhqPc886Vaqpea8dZlxv2fpZ4wSzPUbiiKHoHZzoVndMIMTUL0TZukP3Ps0n/lWO5R5+FA==", + "cpu": [ + "arm64" + ], + "dev": true, + "license": "BSD-3-Clause", + "optional": true, + "os": [ + "linux" + ] + }, + "node_modules/@avh4/elm-format-linux-x64": { + "version": "0.8.7-2", + "resolved": "https://registry.npmjs.org/@avh4/elm-format-linux-x64/-/elm-format-linux-x64-0.8.7-2.tgz", + "integrity": "sha512-kmncfJrTBjVT94JtQvMf4M5Pn2Yl0sZt3wo7AzgFiDnB/CiZ+KjJyXuWM64NeGiv4MQqzPq65tsFXUH1CIJeiQ==", + "cpu": [ + "x64" + ], + "dev": true, + "license": "BSD-3-Clause", + "optional": true, + "os": [ + "linux" + ] + }, + "node_modules/@avh4/elm-format-win32-x64": { + "version": "0.8.7-2", + "resolved": "https://registry.npmjs.org/@avh4/elm-format-win32-x64/-/elm-format-win32-x64-0.8.7-2.tgz", + "integrity": "sha512-sBdMBGq/8mD8Y5C+fIr5vlb3N50yB7S1MfgeAq2QEbvkr/sKrCZI540i43lZDH9gWsfA1w2W8wCe0penFYzsGw==", + "cpu": [ + "x64" + ], + "dev": true, + "license": "BSD-3-Clause", + "optional": true, + "os": [ + "win32" + ] + }, + "node_modules/@babel/code-frame": { + "version": "7.26.2", + "resolved": "https://registry.npmjs.org/@babel/code-frame/-/code-frame-7.26.2.tgz", + "integrity": "sha512-RJlIHRueQgwWitWgF8OdFYGZX328Ax5BCemNGlqHfplnRT9ESi8JkFlvaVYbS+UubVY6dpv87Fs2u5M29iNFVQ==", + "dev": true, + "license": "MIT", + "dependencies": { + "@babel/helper-validator-identifier": "^7.25.9", + "js-tokens": "^4.0.0", + "picocolors": "^1.0.0" + }, + "engines": { + "node": ">=6.9.0" + } + }, + "node_modules/@babel/compat-data": { + "version": "7.26.8", + "resolved": "https://registry.npmjs.org/@babel/compat-data/-/compat-data-7.26.8.tgz", + "integrity": "sha512-oH5UPLMWR3L2wEFLnFJ1TZXqHufiTKAiLfqw5zkhS4dKXLJ10yVztfil/twG8EDTA4F/tvVNw9nOl4ZMslB8rQ==", + "dev": true, + "license": "MIT", + "engines": { + "node": ">=6.9.0" + } + }, + "node_modules/@babel/core": { + "version": "7.26.10", + "resolved": "https://registry.npmjs.org/@babel/core/-/core-7.26.10.tgz", + "integrity": "sha512-vMqyb7XCDMPvJFFOaT9kxtiRh42GwlZEg1/uIgtZshS5a/8OaduUfCi7kynKgc3Tw/6Uo2D+db9qBttghhmxwQ==", + "dev": true, + "license": "MIT", + "dependencies": { + "@ampproject/remapping": "^2.2.0", + "@babel/code-frame": "^7.26.2", + "@babel/generator": "^7.26.10", + "@babel/helper-compilation-targets": "^7.26.5", + "@babel/helper-module-transforms": "^7.26.0", + "@babel/helpers": "^7.26.10", + "@babel/parser": "^7.26.10", + "@babel/template": "^7.26.9", + "@babel/traverse": "^7.26.10", + "@babel/types": "^7.26.10", + "convert-source-map": "^2.0.0", + "debug": "^4.1.0", + "gensync": "^1.0.0-beta.2", + "json5": "^2.2.3", + "semver": "^6.3.1" + }, + "engines": { + "node": ">=6.9.0" + }, + "funding": { + "type": "opencollective", + "url": "https://opencollective.com/babel" + } + }, + "node_modules/@babel/generator": { + "version": "7.27.0", + "resolved": "https://registry.npmjs.org/@babel/generator/-/generator-7.27.0.tgz", + "integrity": "sha512-VybsKvpiN1gU1sdMZIp7FcqphVVKEwcuj02x73uvcHE0PTihx1nlBcowYWhDwjpoAXRv43+gDzyggGnn1XZhVw==", + "dev": true, + "license": "MIT", + "dependencies": { + "@babel/parser": "^7.27.0", + "@babel/types": "^7.27.0", + "@jridgewell/gen-mapping": "^0.3.5", + "@jridgewell/trace-mapping": "^0.3.25", + "jsesc": "^3.0.2" + }, + "engines": { + "node": ">=6.9.0" + } + }, + "node_modules/@babel/helper-compilation-targets": { + "version": "7.27.0", + "resolved": "https://registry.npmjs.org/@babel/helper-compilation-targets/-/helper-compilation-targets-7.27.0.tgz", + "integrity": "sha512-LVk7fbXml0H2xH34dFzKQ7TDZ2G4/rVTOrq9V+icbbadjbVxxeFeDsNHv2SrZeWoA+6ZiTyWYWtScEIW07EAcA==", + "dev": true, + "license": "MIT", + "dependencies": { + "@babel/compat-data": "^7.26.8", + "@babel/helper-validator-option": "^7.25.9", + "browserslist": "^4.24.0", + "lru-cache": "^5.1.1", + "semver": "^6.3.1" + }, + "engines": { + "node": ">=6.9.0" + } + }, + "node_modules/@babel/helper-module-imports": { + "version": "7.25.9", + "resolved": "https://registry.npmjs.org/@babel/helper-module-imports/-/helper-module-imports-7.25.9.tgz", + "integrity": "sha512-tnUA4RsrmflIM6W6RFTLFSXITtl0wKjgpnLgXyowocVPrbYrLUXSBXDgTs8BlbmIzIdlBySRQjINYs2BAkiLtw==", + "dev": true, + "license": "MIT", + "dependencies": { + "@babel/traverse": "^7.25.9", + "@babel/types": "^7.25.9" + }, + "engines": { + "node": ">=6.9.0" + } + }, + "node_modules/@babel/helper-module-transforms": { + "version": "7.26.0", + "resolved": "https://registry.npmjs.org/@babel/helper-module-transforms/-/helper-module-transforms-7.26.0.tgz", + "integrity": "sha512-xO+xu6B5K2czEnQye6BHA7DolFFmS3LB7stHZFaOLb1pAwO1HWLS8fXA+eh0A2yIvltPVmx3eNNDBJA2SLHXFw==", + "dev": true, + "license": "MIT", + "dependencies": { + "@babel/helper-module-imports": "^7.25.9", + "@babel/helper-validator-identifier": "^7.25.9", + "@babel/traverse": "^7.25.9" + }, + "engines": { + "node": ">=6.9.0" + }, + "peerDependencies": { + "@babel/core": "^7.0.0" + } + }, + "node_modules/@babel/helper-plugin-utils": { + "version": "7.26.5", + "resolved": "https://registry.npmjs.org/@babel/helper-plugin-utils/-/helper-plugin-utils-7.26.5.tgz", + "integrity": "sha512-RS+jZcRdZdRFzMyr+wcsaqOmld1/EqTghfaBGQQd/WnRdzdlvSZ//kF7U8VQTxf1ynZ4cjUcYgjVGx13ewNPMg==", + "dev": true, + "license": "MIT", + "engines": { + "node": ">=6.9.0" + } + }, + "node_modules/@babel/helper-string-parser": { + "version": "7.25.9", + "resolved": "https://registry.npmjs.org/@babel/helper-string-parser/-/helper-string-parser-7.25.9.tgz", + "integrity": "sha512-4A/SCr/2KLd5jrtOMFzaKjVtAei3+2r/NChoBNoZ3EyP/+GlhoaEGoWOZUmFmoITP7zOJyHIMm+DYRd8o3PvHA==", + "dev": true, + "license": "MIT", + "engines": { + "node": ">=6.9.0" + } + }, + "node_modules/@babel/helper-validator-identifier": { + "version": "7.25.9", + "resolved": "https://registry.npmjs.org/@babel/helper-validator-identifier/-/helper-validator-identifier-7.25.9.tgz", + "integrity": "sha512-Ed61U6XJc3CVRfkERJWDz4dJwKe7iLmmJsbOGu9wSloNSFttHV0I8g6UAgb7qnK5ly5bGLPd4oXZlxCdANBOWQ==", + "dev": true, + "license": "MIT", + "engines": { + "node": ">=6.9.0" + } + }, + "node_modules/@babel/helper-validator-option": { + "version": "7.25.9", + "resolved": "https://registry.npmjs.org/@babel/helper-validator-option/-/helper-validator-option-7.25.9.tgz", + "integrity": "sha512-e/zv1co8pp55dNdEcCynfj9X7nyUKUXoUEwfXqaZt0omVOmDe9oOTdKStH4GmAw6zxMFs50ZayuMfHDKlO7Tfw==", + "dev": true, + "license": "MIT", + "engines": { + "node": ">=6.9.0" + } + }, + "node_modules/@babel/helpers": { + "version": "7.27.0", + "resolved": "https://registry.npmjs.org/@babel/helpers/-/helpers-7.27.0.tgz", + "integrity": "sha512-U5eyP/CTFPuNE3qk+WZMxFkp/4zUzdceQlfzf7DdGdhp+Fezd7HD+i8Y24ZuTMKX3wQBld449jijbGq6OdGNQg==", + "dev": true, + "license": "MIT", + "dependencies": { + "@babel/template": "^7.27.0", + "@babel/types": "^7.27.0" + }, + "engines": { + "node": ">=6.9.0" + } + }, + "node_modules/@babel/parser": { + "version": "7.27.0", + "resolved": "https://registry.npmjs.org/@babel/parser/-/parser-7.27.0.tgz", + "integrity": "sha512-iaepho73/2Pz7w2eMS0Q5f83+0RKI7i4xmiYeBmDzfRVbQtTOG7Ts0S4HzJVsTMGI9keU8rNfuZr8DKfSt7Yyg==", + "dev": true, + "license": "MIT", + "dependencies": { + "@babel/types": "^7.27.0" + }, + "bin": { + "parser": "bin/babel-parser.js" + }, + "engines": { + "node": ">=6.0.0" + } + }, + "node_modules/@babel/plugin-syntax-async-generators": { + "version": "7.8.4", + "resolved": "https://registry.npmjs.org/@babel/plugin-syntax-async-generators/-/plugin-syntax-async-generators-7.8.4.tgz", + "integrity": "sha512-tycmZxkGfZaxhMRbXlPXuVFpdWlXpir2W4AMhSJgRKzk/eDlIXOhb2LHWoLpDF7TEHylV5zNhykX6KAgHJmTNw==", + "dev": true, + "license": "MIT", + "dependencies": { + "@babel/helper-plugin-utils": "^7.8.0" + }, + "peerDependencies": { + "@babel/core": "^7.0.0-0" + } + }, + "node_modules/@babel/plugin-syntax-bigint": { + "version": "7.8.3", + "resolved": "https://registry.npmjs.org/@babel/plugin-syntax-bigint/-/plugin-syntax-bigint-7.8.3.tgz", + "integrity": "sha512-wnTnFlG+YxQm3vDxpGE57Pj0srRU4sHE/mDkt1qv2YJJSeUAec2ma4WLUnUPeKjyrfntVwe/N6dCXpU+zL3Npg==", + "dev": true, + "license": "MIT", + "dependencies": { + "@babel/helper-plugin-utils": "^7.8.0" + }, + "peerDependencies": { + "@babel/core": "^7.0.0-0" + } + }, + "node_modules/@babel/plugin-syntax-class-properties": { + "version": "7.12.13", + "resolved": "https://registry.npmjs.org/@babel/plugin-syntax-class-properties/-/plugin-syntax-class-properties-7.12.13.tgz", + "integrity": "sha512-fm4idjKla0YahUNgFNLCB0qySdsoPiZP3iQE3rky0mBUtMZ23yDJ9SJdg6dXTSDnulOVqiF3Hgr9nbXvXTQZYA==", + "dev": true, + "license": "MIT", + "dependencies": { + "@babel/helper-plugin-utils": "^7.12.13" + }, + "peerDependencies": { + "@babel/core": "^7.0.0-0" + } + }, + "node_modules/@babel/plugin-syntax-class-static-block": { + "version": "7.14.5", + "resolved": "https://registry.npmjs.org/@babel/plugin-syntax-class-static-block/-/plugin-syntax-class-static-block-7.14.5.tgz", + "integrity": "sha512-b+YyPmr6ldyNnM6sqYeMWE+bgJcJpO6yS4QD7ymxgH34GBPNDM/THBh8iunyvKIZztiwLH4CJZ0RxTk9emgpjw==", + "dev": true, + "license": "MIT", + "dependencies": { + "@babel/helper-plugin-utils": "^7.14.5" + }, + "engines": { + "node": ">=6.9.0" + }, + "peerDependencies": { + "@babel/core": "^7.0.0-0" + } + }, + "node_modules/@babel/plugin-syntax-import-attributes": { + "version": "7.26.0", + "resolved": "https://registry.npmjs.org/@babel/plugin-syntax-import-attributes/-/plugin-syntax-import-attributes-7.26.0.tgz", + "integrity": "sha512-e2dttdsJ1ZTpi3B9UYGLw41hifAubg19AtCu/2I/F1QNVclOBr1dYpTdmdyZ84Xiz43BS/tCUkMAZNLv12Pi+A==", + "dev": true, + "license": "MIT", + "dependencies": { + "@babel/helper-plugin-utils": "^7.25.9" + }, + "engines": { + "node": ">=6.9.0" + }, + "peerDependencies": { + "@babel/core": "^7.0.0-0" + } + }, + "node_modules/@babel/plugin-syntax-import-meta": { + "version": "7.10.4", + "resolved": "https://registry.npmjs.org/@babel/plugin-syntax-import-meta/-/plugin-syntax-import-meta-7.10.4.tgz", + "integrity": "sha512-Yqfm+XDx0+Prh3VSeEQCPU81yC+JWZ2pDPFSS4ZdpfZhp4MkFMaDC1UqseovEKwSUpnIL7+vK+Clp7bfh0iD7g==", + "dev": true, + "license": "MIT", + "dependencies": { + "@babel/helper-plugin-utils": "^7.10.4" + }, + "peerDependencies": { + "@babel/core": "^7.0.0-0" + } + }, + "node_modules/@babel/plugin-syntax-json-strings": { + "version": "7.8.3", + "resolved": "https://registry.npmjs.org/@babel/plugin-syntax-json-strings/-/plugin-syntax-json-strings-7.8.3.tgz", + "integrity": "sha512-lY6kdGpWHvjoe2vk4WrAapEuBR69EMxZl+RoGRhrFGNYVK8mOPAW8VfbT/ZgrFbXlDNiiaxQnAtgVCZ6jv30EA==", + "dev": true, + "license": "MIT", + "dependencies": { + "@babel/helper-plugin-utils": "^7.8.0" + }, + "peerDependencies": { + "@babel/core": "^7.0.0-0" + } + }, + "node_modules/@babel/plugin-syntax-jsx": { + "version": "7.25.9", + "resolved": "https://registry.npmjs.org/@babel/plugin-syntax-jsx/-/plugin-syntax-jsx-7.25.9.tgz", + "integrity": "sha512-ld6oezHQMZsZfp6pWtbjaNDF2tiiCYYDqQszHt5VV437lewP9aSi2Of99CK0D0XB21k7FLgnLcmQKyKzynfeAA==", + "dev": true, + "license": "MIT", + "dependencies": { + "@babel/helper-plugin-utils": "^7.25.9" + }, + "engines": { + "node": ">=6.9.0" + }, + "peerDependencies": { + "@babel/core": "^7.0.0-0" + } + }, + "node_modules/@babel/plugin-syntax-logical-assignment-operators": { + "version": "7.10.4", + "resolved": "https://registry.npmjs.org/@babel/plugin-syntax-logical-assignment-operators/-/plugin-syntax-logical-assignment-operators-7.10.4.tgz", + "integrity": "sha512-d8waShlpFDinQ5MtvGU9xDAOzKH47+FFoney2baFIoMr952hKOLp1HR7VszoZvOsV/4+RRszNY7D17ba0te0ig==", + "dev": true, + "license": "MIT", + "dependencies": { + "@babel/helper-plugin-utils": "^7.10.4" + }, + "peerDependencies": { + "@babel/core": "^7.0.0-0" + } + }, + "node_modules/@babel/plugin-syntax-nullish-coalescing-operator": { + "version": "7.8.3", + "resolved": "https://registry.npmjs.org/@babel/plugin-syntax-nullish-coalescing-operator/-/plugin-syntax-nullish-coalescing-operator-7.8.3.tgz", + "integrity": "sha512-aSff4zPII1u2QD7y+F8oDsz19ew4IGEJg9SVW+bqwpwtfFleiQDMdzA/R+UlWDzfnHFCxxleFT0PMIrR36XLNQ==", + "dev": true, + "license": "MIT", + "dependencies": { + "@babel/helper-plugin-utils": "^7.8.0" + }, + "peerDependencies": { + "@babel/core": "^7.0.0-0" + } + }, + "node_modules/@babel/plugin-syntax-numeric-separator": { + "version": "7.10.4", + "resolved": "https://registry.npmjs.org/@babel/plugin-syntax-numeric-separator/-/plugin-syntax-numeric-separator-7.10.4.tgz", + "integrity": "sha512-9H6YdfkcK/uOnY/K7/aA2xpzaAgkQn37yzWUMRK7OaPOqOpGS1+n0H5hxT9AUw9EsSjPW8SVyMJwYRtWs3X3ug==", + "dev": true, + "license": "MIT", + "dependencies": { + "@babel/helper-plugin-utils": "^7.10.4" + }, + "peerDependencies": { + "@babel/core": "^7.0.0-0" + } + }, + "node_modules/@babel/plugin-syntax-object-rest-spread": { + "version": "7.8.3", + "resolved": "https://registry.npmjs.org/@babel/plugin-syntax-object-rest-spread/-/plugin-syntax-object-rest-spread-7.8.3.tgz", + "integrity": "sha512-XoqMijGZb9y3y2XskN+P1wUGiVwWZ5JmoDRwx5+3GmEplNyVM2s2Dg8ILFQm8rWM48orGy5YpI5Bl8U1y7ydlA==", + "dev": true, + "license": "MIT", + "dependencies": { + "@babel/helper-plugin-utils": "^7.8.0" + }, + "peerDependencies": { + "@babel/core": "^7.0.0-0" + } + }, + "node_modules/@babel/plugin-syntax-optional-catch-binding": { + "version": "7.8.3", + "resolved": "https://registry.npmjs.org/@babel/plugin-syntax-optional-catch-binding/-/plugin-syntax-optional-catch-binding-7.8.3.tgz", + "integrity": "sha512-6VPD0Pc1lpTqw0aKoeRTMiB+kWhAoT24PA+ksWSBrFtl5SIRVpZlwN3NNPQjehA2E/91FV3RjLWoVTglWcSV3Q==", + "dev": true, + "license": "MIT", + "dependencies": { + "@babel/helper-plugin-utils": "^7.8.0" + }, + "peerDependencies": { + "@babel/core": "^7.0.0-0" + } + }, + "node_modules/@babel/plugin-syntax-optional-chaining": { + "version": "7.8.3", + "resolved": "https://registry.npmjs.org/@babel/plugin-syntax-optional-chaining/-/plugin-syntax-optional-chaining-7.8.3.tgz", + "integrity": "sha512-KoK9ErH1MBlCPxV0VANkXW2/dw4vlbGDrFgz8bmUsBGYkFRcbRwMh6cIJubdPrkxRwuGdtCk0v/wPTKbQgBjkg==", + "dev": true, + "license": "MIT", + "dependencies": { + "@babel/helper-plugin-utils": "^7.8.0" + }, + "peerDependencies": { + "@babel/core": "^7.0.0-0" + } + }, + "node_modules/@babel/plugin-syntax-private-property-in-object": { + "version": "7.14.5", + "resolved": "https://registry.npmjs.org/@babel/plugin-syntax-private-property-in-object/-/plugin-syntax-private-property-in-object-7.14.5.tgz", + "integrity": "sha512-0wVnp9dxJ72ZUJDV27ZfbSj6iHLoytYZmh3rFcxNnvsJF3ktkzLDZPy/mA17HGsaQT3/DQsWYX1f1QGWkCoVUg==", + "dev": true, + "license": "MIT", + "dependencies": { + "@babel/helper-plugin-utils": "^7.14.5" + }, + "engines": { + "node": ">=6.9.0" + }, + "peerDependencies": { + "@babel/core": "^7.0.0-0" + } + }, + "node_modules/@babel/plugin-syntax-top-level-await": { + "version": "7.14.5", + "resolved": "https://registry.npmjs.org/@babel/plugin-syntax-top-level-await/-/plugin-syntax-top-level-await-7.14.5.tgz", + "integrity": "sha512-hx++upLv5U1rgYfwe1xBQUhRmU41NEvpUvrp8jkrSCdvGSnM5/qdRMtylJ6PG5OFkBaHkbTAKTnd3/YyESRHFw==", + "dev": true, + "license": "MIT", + "dependencies": { + "@babel/helper-plugin-utils": "^7.14.5" + }, + "engines": { + "node": ">=6.9.0" + }, + "peerDependencies": { + "@babel/core": "^7.0.0-0" + } + }, + "node_modules/@babel/plugin-syntax-typescript": { + "version": "7.25.9", + "resolved": "https://registry.npmjs.org/@babel/plugin-syntax-typescript/-/plugin-syntax-typescript-7.25.9.tgz", + "integrity": "sha512-hjMgRy5hb8uJJjUcdWunWVcoi9bGpJp8p5Ol1229PoN6aytsLwNMgmdftO23wnCLMfVmTwZDWMPNq/D1SY60JQ==", + "dev": true, + "license": "MIT", + "dependencies": { + "@babel/helper-plugin-utils": "^7.25.9" + }, + "engines": { + "node": ">=6.9.0" + }, + "peerDependencies": { + "@babel/core": "^7.0.0-0" + } + }, + "node_modules/@babel/template": { + "version": "7.27.0", + "resolved": "https://registry.npmjs.org/@babel/template/-/template-7.27.0.tgz", + "integrity": "sha512-2ncevenBqXI6qRMukPlXwHKHchC7RyMuu4xv5JBXRfOGVcTy1mXCD12qrp7Jsoxll1EV3+9sE4GugBVRjT2jFA==", + "dev": true, + "license": "MIT", + "dependencies": { + "@babel/code-frame": "^7.26.2", + "@babel/parser": "^7.27.0", + "@babel/types": "^7.27.0" + }, + "engines": { + "node": ">=6.9.0" + } + }, + "node_modules/@babel/traverse": { + "version": "7.27.0", + "resolved": "https://registry.npmjs.org/@babel/traverse/-/traverse-7.27.0.tgz", + "integrity": "sha512-19lYZFzYVQkkHkl4Cy4WrAVcqBkgvV2YM2TU3xG6DIwO7O3ecbDPfW3yM3bjAGcqcQHi+CCtjMR3dIEHxsd6bA==", + "dev": true, + "license": "MIT", + "dependencies": { + "@babel/code-frame": "^7.26.2", + "@babel/generator": "^7.27.0", + "@babel/parser": "^7.27.0", + "@babel/template": "^7.27.0", + "@babel/types": "^7.27.0", + "debug": "^4.3.1", + "globals": "^11.1.0" + }, + "engines": { + "node": ">=6.9.0" + } + }, + "node_modules/@babel/traverse/node_modules/globals": { + "version": "11.12.0", + "resolved": "https://registry.npmjs.org/globals/-/globals-11.12.0.tgz", + "integrity": "sha512-WOBp/EEGUiIsJSp7wcv/y6MO+lV9UoncWqxuFfm8eBwzWNgyfBd6Gz+IeKQ9jCmyhoH99g15M3T+QaVHFjizVA==", + "dev": true, + "license": "MIT", + "engines": { + "node": ">=4" + } + }, + "node_modules/@babel/types": { + "version": "7.27.0", + "resolved": "https://registry.npmjs.org/@babel/types/-/types-7.27.0.tgz", + "integrity": "sha512-H45s8fVLYjbhFH62dIJ3WtmJ6RSPt/3DRO0ZcT2SUiYiQyz3BLVb9ADEnLl91m74aQPS3AzzeajZHYOalWe3bg==", + "dev": true, + "license": "MIT", + "dependencies": { + "@babel/helper-string-parser": "^7.25.9", + "@babel/helper-validator-identifier": "^7.25.9" + }, + "engines": { + "node": ">=6.9.0" + } + }, + "node_modules/@bcoe/v8-coverage": { + "version": "0.2.3", + "resolved": "https://registry.npmjs.org/@bcoe/v8-coverage/-/v8-coverage-0.2.3.tgz", + "integrity": "sha512-0hYQ8SB4Db5zvZB4axdMHGwEaQjkZzFjQiN9LVYvIFB2nSUHW9tYpxWriPrWDASIxiaXax83REcLxuSdnGPZtw==", + "dev": true, + "license": "MIT" + }, + "node_modules/@blakeembrey/deque": { + "version": "1.0.5", + "resolved": "https://registry.npmjs.org/@blakeembrey/deque/-/deque-1.0.5.tgz", + "integrity": "sha512-6xnwtvp9DY1EINIKdTfvfeAtCYw4OqBZJhtiqkT3ivjnEfa25VQ3TsKvaFfKm8MyGIEfE95qLe+bNEt3nB0Ylg==", + "dev": true, + "license": "Apache-2.0" + }, + "node_modules/@blakeembrey/template": { + "version": "1.2.0", + "resolved": "https://registry.npmjs.org/@blakeembrey/template/-/template-1.2.0.tgz", + "integrity": "sha512-w/63nURdkRPpg3AXbNr7lPv6HgOuVDyefTumiXsbXxtIwcuk5EXayWR5OpSwDjsQPgaYsfUSedMduaNOjAYY8A==", + "dev": true, + "license": "Apache-2.0" + }, + "node_modules/@elm_binaries/darwin_arm64": { + "version": "0.19.1-0", + "resolved": "https://registry.npmjs.org/@elm_binaries/darwin_arm64/-/darwin_arm64-0.19.1-0.tgz", + "integrity": "sha512-mjbsH7BNHEAmoE2SCJFcfk5fIHwFIpxtSgnEAqMsVLpBUFoEtAeX+LQ+N0vSFJB3WAh73+QYx/xSluxxLcL6dA==", + "cpu": [ + "arm64" + ], + "dev": true, + "license": "BSD-3-Clause", + "optional": true, + "os": [ + "darwin" + ] + }, + "node_modules/@elm_binaries/darwin_x64": { + "version": "0.19.1-0", + "resolved": "https://registry.npmjs.org/@elm_binaries/darwin_x64/-/darwin_x64-0.19.1-0.tgz", + "integrity": "sha512-QGUtrZTPBzaxgi9al6nr+9313wrnUVHuijzUK39UsPS+pa+n6CmWyV/69sHZeX9qy6UfeugE0PzF3qcUiy2GDQ==", + "cpu": [ + "x64" + ], + "dev": true, + "license": "BSD-3-Clause", + "optional": true, + "os": [ + "darwin" + ] + }, + "node_modules/@elm_binaries/linux_x64": { + "version": "0.19.1-0", + "resolved": "https://registry.npmjs.org/@elm_binaries/linux_x64/-/linux_x64-0.19.1-0.tgz", + "integrity": "sha512-T1ZrWVhg2kKAsi8caOd3vp/1A3e21VuCpSG63x8rDie50fHbCytTway9B8WHEdnBFv4mYWiA68dzGxYCiFmU2w==", + "cpu": [ + "x64" + ], + "dev": true, + "license": "BSD-3-Clause", + "optional": true, + "os": [ + "linux" + ] + }, + "node_modules/@elm_binaries/win32_x64": { + "version": "0.19.1-0", + "resolved": "https://registry.npmjs.org/@elm_binaries/win32_x64/-/win32_x64-0.19.1-0.tgz", + "integrity": "sha512-yDleiXqSE9EcqKtd9SkC/4RIW8I71YsXzMPL79ub2bBPHjWTcoyyeBbYjoOB9SxSlArJ74HaoBApzT6hY7Zobg==", + "cpu": [ + "x64" + ], + "dev": true, + "license": "BSD-3-Clause", + "optional": true, + "os": [ + "win32" + ] + }, + "node_modules/@eslint-community/eslint-utils": { + "version": "4.5.1", + "resolved": "https://registry.npmjs.org/@eslint-community/eslint-utils/-/eslint-utils-4.5.1.tgz", + "integrity": "sha512-soEIOALTfTK6EjmKMMoLugwaP0rzkad90iIWd1hMO9ARkSAyjfMfkRRhLvD5qH7vvM0Cg72pieUfR6yh6XxC4w==", + "dev": true, + "license": "MIT", + "dependencies": { + "eslint-visitor-keys": "^3.4.3" + }, + "engines": { + "node": "^12.22.0 || ^14.17.0 || >=16.0.0" + }, + "funding": { + "url": "https://opencollective.com/eslint" + }, + "peerDependencies": { + "eslint": "^6.0.0 || ^7.0.0 || >=8.0.0" + } + }, + "node_modules/@eslint-community/eslint-utils/node_modules/eslint-visitor-keys": { + "version": "3.4.3", + "resolved": "https://registry.npmjs.org/eslint-visitor-keys/-/eslint-visitor-keys-3.4.3.tgz", + "integrity": "sha512-wpc+LXeiyiisxPlEkUzU6svyS1frIO3Mgxj1fdy7Pm8Ygzguax2N3Fa/D/ag1WqbOprdI+uY6wMUl8/a2G+iag==", + "dev": true, + "license": "Apache-2.0", + "engines": { + "node": "^12.22.0 || ^14.17.0 || >=16.0.0" + }, + "funding": { + "url": "https://opencollective.com/eslint" + } + }, + "node_modules/@eslint-community/regexpp": { + "version": "4.12.1", + "resolved": "https://registry.npmjs.org/@eslint-community/regexpp/-/regexpp-4.12.1.tgz", + "integrity": "sha512-CCZCDJuduB9OUkFkY2IgppNZMi2lBQgD2qzwXkEia16cge2pijY/aXi96CJMquDMn3nJdlPV1A5KrJEXwfLNzQ==", + "dev": true, + "license": "MIT", + "engines": { + "node": "^12.0.0 || ^14.0.0 || >=16.0.0" + } + }, + "node_modules/@eslint/config-array": { + "version": "0.21.0", + "resolved": "https://registry.npmjs.org/@eslint/config-array/-/config-array-0.21.0.tgz", + "integrity": "sha512-ENIdc4iLu0d93HeYirvKmrzshzofPw6VkZRKQGe9Nv46ZnWUzcF1xV01dcvEg/1wXUR61OmmlSfyeyO7EvjLxQ==", + "dev": true, + "license": "Apache-2.0", + "dependencies": { + "@eslint/object-schema": "^2.1.6", + "debug": "^4.3.1", + "minimatch": "^3.1.2" + }, + "engines": { + "node": "^18.18.0 || ^20.9.0 || >=21.1.0" + } + }, + "node_modules/@eslint/config-array/node_modules/minimatch": { + "version": "3.1.2", + "resolved": "https://registry.npmjs.org/minimatch/-/minimatch-3.1.2.tgz", + "integrity": "sha512-J7p63hRiAjw1NDEww1W7i37+ByIrOWO5XQQAzZ3VOcL0PNybwpfmV/N05zFAzwQ9USyEcX6t3UO+K5aqBQOIHw==", + "dev": true, + "license": "ISC", + "dependencies": { + "brace-expansion": "^1.1.7" + }, + "engines": { + "node": "*" + } + }, + "node_modules/@eslint/config-helpers": { + "version": "0.3.1", + "resolved": "https://registry.npmjs.org/@eslint/config-helpers/-/config-helpers-0.3.1.tgz", + "integrity": "sha512-xR93k9WhrDYpXHORXpxVL5oHj3Era7wo6k/Wd8/IsQNnZUTzkGS29lyn3nAT05v6ltUuTFVCCYDEGfy2Or/sPA==", + "dev": true, + "license": "Apache-2.0", + "engines": { + "node": "^18.18.0 || ^20.9.0 || >=21.1.0" + } + }, + "node_modules/@eslint/core": { + "version": "0.15.2", + "resolved": "https://registry.npmjs.org/@eslint/core/-/core-0.15.2.tgz", + "integrity": "sha512-78Md3/Rrxh83gCxoUc0EiciuOHsIITzLy53m3d9UyiW8y9Dj2D29FeETqyKA+BRK76tnTp6RXWb3pCay8Oyomg==", + "dev": true, + "license": "Apache-2.0", + "dependencies": { + "@types/json-schema": "^7.0.15" + }, + "engines": { + "node": "^18.18.0 || ^20.9.0 || >=21.1.0" + } + }, + "node_modules/@eslint/eslintrc": { + "version": "3.3.1", + "resolved": "https://registry.npmjs.org/@eslint/eslintrc/-/eslintrc-3.3.1.tgz", + "integrity": "sha512-gtF186CXhIl1p4pJNGZw8Yc6RlshoePRvE0X91oPGb3vZ8pM3qOS9W9NGPat9LziaBV7XrJWGylNQXkGcnM3IQ==", + "dev": true, + "license": "MIT", + "dependencies": { + "ajv": "^6.12.4", + "debug": "^4.3.2", + "espree": "^10.0.1", + "globals": "^14.0.0", + "ignore": "^5.2.0", + "import-fresh": "^3.2.1", + "js-yaml": "^4.1.0", + "minimatch": "^3.1.2", + "strip-json-comments": "^3.1.1" + }, + "engines": { + "node": "^18.18.0 || ^20.9.0 || >=21.1.0" + }, + "funding": { + "url": "https://opencollective.com/eslint" + } + }, + "node_modules/@eslint/eslintrc/node_modules/argparse": { + "version": "2.0.1", + "resolved": "https://registry.npmjs.org/argparse/-/argparse-2.0.1.tgz", + "integrity": "sha512-8+9WqebbFzpX9OR+Wa6O29asIogeRMzcGtAINdpMHHyAg10f05aSFVBbcEqGf/PXw1EjAZ+q2/bEBg3DvurK3Q==", + "dev": true, + "license": "Python-2.0" + }, + "node_modules/@eslint/eslintrc/node_modules/globals": { + "version": "14.0.0", + "resolved": "https://registry.npmjs.org/globals/-/globals-14.0.0.tgz", + "integrity": "sha512-oahGvuMGQlPw/ivIYBjVSrWAfWLBeku5tpPE2fOPLi+WHffIWbuh2tCjhyQhTBPMf5E9jDEH4FOmTYgYwbKwtQ==", + "dev": true, + "license": "MIT", + "engines": { + "node": ">=18" + }, + "funding": { + "url": "https://github.com/sponsors/sindresorhus" + } + }, + "node_modules/@eslint/eslintrc/node_modules/js-yaml": { + "version": "4.1.0", + "resolved": "https://registry.npmjs.org/js-yaml/-/js-yaml-4.1.0.tgz", + "integrity": "sha512-wpxZs9NoxZaJESJGIZTyDEaYpl0FKSA+FB9aJiyemKhMwkxQg63h4T1KJgUGHpTqPDNRcmmYLugrRjJlBtWvRA==", + "dev": true, + "license": "MIT", + "dependencies": { + "argparse": "^2.0.1" + }, + "bin": { + "js-yaml": "bin/js-yaml.js" + } + }, + "node_modules/@eslint/eslintrc/node_modules/minimatch": { + "version": "3.1.2", + "resolved": "https://registry.npmjs.org/minimatch/-/minimatch-3.1.2.tgz", + "integrity": "sha512-J7p63hRiAjw1NDEww1W7i37+ByIrOWO5XQQAzZ3VOcL0PNybwpfmV/N05zFAzwQ9USyEcX6t3UO+K5aqBQOIHw==", + "dev": true, + "license": "ISC", + "dependencies": { + "brace-expansion": "^1.1.7" + }, + "engines": { + "node": "*" + } + }, + "node_modules/@eslint/js": { + "version": "9.33.0", + "resolved": "https://registry.npmjs.org/@eslint/js/-/js-9.33.0.tgz", + "integrity": "sha512-5K1/mKhWaMfreBGJTwval43JJmkip0RmM+3+IuqupeSKNC/Th2Kc7ucaq5ovTSra/OOKB9c58CGSz3QMVbWt0A==", + "dev": true, + "license": "MIT", + "engines": { + "node": "^18.18.0 || ^20.9.0 || >=21.1.0" + }, + "funding": { + "url": "https://eslint.org/donate" + } + }, + "node_modules/@eslint/object-schema": { + "version": "2.1.6", + "resolved": "https://registry.npmjs.org/@eslint/object-schema/-/object-schema-2.1.6.tgz", + "integrity": "sha512-RBMg5FRL0I0gs51M/guSAj5/e14VQ4tpZnQNWwuDT66P14I43ItmPfIZRhO9fUVIPOAQXU47atlywZ/czoqFPA==", + "dev": true, + "license": "Apache-2.0", + "engines": { + "node": "^18.18.0 || ^20.9.0 || >=21.1.0" + } + }, + "node_modules/@eslint/plugin-kit": { + "version": "0.3.5", + "resolved": "https://registry.npmjs.org/@eslint/plugin-kit/-/plugin-kit-0.3.5.tgz", + "integrity": "sha512-Z5kJ+wU3oA7MMIqVR9tyZRtjYPr4OC004Q4Rw7pgOKUOKkJfZ3O24nz3WYfGRpMDNmcOi3TwQOmgm7B7Tpii0w==", + "dev": true, + "license": "Apache-2.0", + "dependencies": { + "@eslint/core": "^0.15.2", + "levn": "^0.4.1" + }, + "engines": { + "node": "^18.18.0 || ^20.9.0 || >=21.1.0" + } + }, + "node_modules/@humanfs/core": { + "version": "0.19.1", + "resolved": "https://registry.npmjs.org/@humanfs/core/-/core-0.19.1.tgz", + "integrity": "sha512-5DyQ4+1JEUzejeK1JGICcideyfUbGixgS9jNgex5nqkW+cY7WZhxBigmieN5Qnw9ZosSNVC9KQKyb+GUaGyKUA==", + "dev": true, + "license": "Apache-2.0", + "engines": { + "node": ">=18.18.0" + } + }, + "node_modules/@humanfs/node": { + "version": "0.16.6", + "resolved": "https://registry.npmjs.org/@humanfs/node/-/node-0.16.6.tgz", + "integrity": "sha512-YuI2ZHQL78Q5HbhDiBA1X4LmYdXCKCMQIfw0pw7piHJwyREFebJUvrQN4cMssyES6x+vfUbx1CIpaQUKYdQZOw==", + "dev": true, + "license": "Apache-2.0", + "dependencies": { + "@humanfs/core": "^0.19.1", + "@humanwhocodes/retry": "^0.3.0" + }, + "engines": { + "node": ">=18.18.0" + } + }, + "node_modules/@humanfs/node/node_modules/@humanwhocodes/retry": { + "version": "0.3.1", + "resolved": "https://registry.npmjs.org/@humanwhocodes/retry/-/retry-0.3.1.tgz", + "integrity": "sha512-JBxkERygn7Bv/GbN5Rv8Ul6LVknS+5Bp6RgDC/O8gEBU/yeH5Ui5C/OlWrTb6qct7LjjfT6Re2NxB0ln0yYybA==", + "dev": true, + "license": "Apache-2.0", + "engines": { + "node": ">=18.18" + }, + "funding": { + "type": "github", + "url": "https://github.com/sponsors/nzakas" + } + }, + "node_modules/@humanwhocodes/module-importer": { + "version": "1.0.1", + "resolved": "https://registry.npmjs.org/@humanwhocodes/module-importer/-/module-importer-1.0.1.tgz", + "integrity": "sha512-bxveV4V8v5Yb4ncFTT3rPSgZBOpCkjfK0y4oVVVJwIuDVBRMDXrPyXRL988i5ap9m9bnyEEjWfm5WkBmtffLfA==", + "dev": true, + "license": "Apache-2.0", + "engines": { + "node": ">=12.22" + }, + "funding": { + "type": "github", + "url": "https://github.com/sponsors/nzakas" + } + }, + "node_modules/@humanwhocodes/retry": { + "version": "0.4.2", + "resolved": "https://registry.npmjs.org/@humanwhocodes/retry/-/retry-0.4.2.tgz", + "integrity": "sha512-xeO57FpIu4p1Ri3Jq/EXq4ClRm86dVF2z/+kvFnyqVYRavTZmaFaUBbWCOuuTh0o/g7DSsk6kc2vrS4Vl5oPOQ==", + "dev": true, + "license": "Apache-2.0", + "engines": { + "node": ">=18.18" + }, + "funding": { + "type": "github", + "url": "https://github.com/sponsors/nzakas" + } + }, + "node_modules/@istanbuljs/load-nyc-config": { + "version": "1.1.0", + "resolved": "https://registry.npmjs.org/@istanbuljs/load-nyc-config/-/load-nyc-config-1.1.0.tgz", + "integrity": "sha512-VjeHSlIzpv/NyD3N0YuHfXOPDIixcA1q2ZV98wsMqcYlPmv2n3Yb2lYP9XMElnaFVXg5A7YLTeLu6V84uQDjmQ==", + "dev": true, + "license": "ISC", + "dependencies": { + "camelcase": "^5.3.1", + "find-up": "^4.1.0", + "get-package-type": "^0.1.0", + "js-yaml": "^3.13.1", + "resolve-from": "^5.0.0" + }, + "engines": { + "node": ">=8" + } + }, + "node_modules/@istanbuljs/load-nyc-config/node_modules/find-up": { + "version": "4.1.0", + "resolved": "https://registry.npmjs.org/find-up/-/find-up-4.1.0.tgz", + "integrity": "sha512-PpOwAdQ/YlXQ2vj8a3h8IipDuYRi3wceVQQGYWxNINccq40Anw7BlsEXCMbt1Zt+OLA6Fq9suIpIWD0OsnISlw==", + "dev": true, + "license": "MIT", + "dependencies": { + "locate-path": "^5.0.0", + "path-exists": "^4.0.0" + }, + "engines": { + "node": ">=8" + } + }, + "node_modules/@istanbuljs/load-nyc-config/node_modules/locate-path": { + "version": "5.0.0", + "resolved": "https://registry.npmjs.org/locate-path/-/locate-path-5.0.0.tgz", + "integrity": "sha512-t7hw9pI+WvuwNJXwk5zVHpyhIqzg2qTlklJOf0mVxGSbe3Fp2VieZcduNYjaLDoy6p9uGpQEGWG87WpMKlNq8g==", + "dev": true, + "license": "MIT", + "dependencies": { + "p-locate": "^4.1.0" + }, + "engines": { + "node": ">=8" + } + }, + "node_modules/@istanbuljs/load-nyc-config/node_modules/p-limit": { + "version": "2.3.0", + "resolved": "https://registry.npmjs.org/p-limit/-/p-limit-2.3.0.tgz", + "integrity": "sha512-//88mFWSJx8lxCzwdAABTJL2MyWB12+eIY7MDL2SqLmAkeKU9qxRvWuSyTjm3FUmpBEMuFfckAIqEaVGUDxb6w==", + "dev": true, + "license": "MIT", + "dependencies": { + "p-try": "^2.0.0" + }, + "engines": { + "node": ">=6" + }, + "funding": { + "url": "https://github.com/sponsors/sindresorhus" + } + }, + "node_modules/@istanbuljs/load-nyc-config/node_modules/p-locate": { + "version": "4.1.0", + "resolved": "https://registry.npmjs.org/p-locate/-/p-locate-4.1.0.tgz", + "integrity": "sha512-R79ZZ/0wAxKGu3oYMlz8jy/kbhsNrS7SKZ7PxEHBgJ5+F2mtFW2fK2cOtBh1cHYkQsbzFV7I+EoRKe6Yt0oK7A==", + "dev": true, + "license": "MIT", + "dependencies": { + "p-limit": "^2.2.0" + }, + "engines": { + "node": ">=8" + } + }, + "node_modules/@istanbuljs/schema": { + "version": "0.1.3", + "resolved": "https://registry.npmjs.org/@istanbuljs/schema/-/schema-0.1.3.tgz", + "integrity": "sha512-ZXRY4jNvVgSVQ8DL3LTcakaAtXwTVUxE81hslsyD2AtoXW/wVob10HkOJ1X/pAlcI7D+2YoZKg5do8G/w6RYgA==", + "dev": true, + "license": "MIT", + "engines": { + "node": ">=8" + } + }, + "node_modules/@jest/console": { + "version": "29.7.0", + "resolved": "https://registry.npmjs.org/@jest/console/-/console-29.7.0.tgz", + "integrity": "sha512-5Ni4CU7XHQi32IJ398EEP4RrB8eV09sXP2ROqD4bksHrnTree52PsxvX8tpL8LvTZ3pFzXyPbNQReSN41CAhOg==", + "dev": true, + "license": "MIT", + "dependencies": { + "@jest/types": "^29.6.3", + "@types/node": "*", + "chalk": "^4.0.0", + "jest-message-util": "^29.7.0", + "jest-util": "^29.7.0", + "slash": "^3.0.0" + }, + "engines": { + "node": "^14.15.0 || ^16.10.0 || >=18.0.0" + } + }, + "node_modules/@jest/core": { + "version": "29.7.0", + "resolved": "https://registry.npmjs.org/@jest/core/-/core-29.7.0.tgz", + "integrity": "sha512-n7aeXWKMnGtDA48y8TLWJPJmLmmZ642Ceo78cYWEpiD7FzDgmNDV/GCVRorPABdXLJZ/9wzzgZAlHjXjxDHGsg==", + "dev": true, + "license": "MIT", + "dependencies": { + "@jest/console": "^29.7.0", + "@jest/reporters": "^29.7.0", + "@jest/test-result": "^29.7.0", + "@jest/transform": "^29.7.0", + "@jest/types": "^29.6.3", + "@types/node": "*", + "ansi-escapes": "^4.2.1", + "chalk": "^4.0.0", + "ci-info": "^3.2.0", + "exit": "^0.1.2", + "graceful-fs": "^4.2.9", + "jest-changed-files": "^29.7.0", + "jest-config": "^29.7.0", + "jest-haste-map": "^29.7.0", + "jest-message-util": "^29.7.0", + "jest-regex-util": "^29.6.3", + "jest-resolve": "^29.7.0", + "jest-resolve-dependencies": "^29.7.0", + "jest-runner": "^29.7.0", + "jest-runtime": "^29.7.0", + "jest-snapshot": "^29.7.0", + "jest-util": "^29.7.0", + "jest-validate": "^29.7.0", + "jest-watcher": "^29.7.0", + "micromatch": "^4.0.4", + "pretty-format": "^29.7.0", + "slash": "^3.0.0", + "strip-ansi": "^6.0.0" + }, + "engines": { + "node": "^14.15.0 || ^16.10.0 || >=18.0.0" + }, + "peerDependencies": { + "node-notifier": "^8.0.1 || ^9.0.0 || ^10.0.0" + }, + "peerDependenciesMeta": { + "node-notifier": { + "optional": true + } + } + }, + "node_modules/@jest/environment": { + "version": "29.7.0", + "resolved": "https://registry.npmjs.org/@jest/environment/-/environment-29.7.0.tgz", + "integrity": "sha512-aQIfHDq33ExsN4jP1NWGXhxgQ/wixs60gDiKO+XVMd8Mn0NWPWgc34ZQDTb2jKaUWQ7MuwoitXAsN2XVXNMpAw==", + "dev": true, + "license": "MIT", + "dependencies": { + "@jest/fake-timers": "^29.7.0", + "@jest/types": "^29.6.3", + "@types/node": "*", + "jest-mock": "^29.7.0" + }, + "engines": { + "node": "^14.15.0 || ^16.10.0 || >=18.0.0" + } + }, + "node_modules/@jest/expect": { + "version": "29.7.0", + "resolved": "https://registry.npmjs.org/@jest/expect/-/expect-29.7.0.tgz", + "integrity": "sha512-8uMeAMycttpva3P1lBHB8VciS9V0XAr3GymPpipdyQXbBcuhkLQOSe8E/p92RyAdToS6ZD1tFkX+CkhoECE0dQ==", + "dev": true, + "license": "MIT", + "dependencies": { + "expect": "^29.7.0", + "jest-snapshot": "^29.7.0" + }, + "engines": { + "node": "^14.15.0 || ^16.10.0 || >=18.0.0" + } + }, + "node_modules/@jest/expect-utils": { + "version": "29.7.0", + "resolved": "https://registry.npmjs.org/@jest/expect-utils/-/expect-utils-29.7.0.tgz", + "integrity": "sha512-GlsNBWiFQFCVi9QVSx7f5AgMeLxe9YCCs5PuP2O2LdjDAA8Jh9eX7lA1Jq/xdXw3Wb3hyvlFNfZIfcRetSzYcA==", + "dev": true, + "license": "MIT", + "dependencies": { + "jest-get-type": "^29.6.3" + }, + "engines": { + "node": "^14.15.0 || ^16.10.0 || >=18.0.0" + } + }, + "node_modules/@jest/fake-timers": { + "version": "29.7.0", + "resolved": "https://registry.npmjs.org/@jest/fake-timers/-/fake-timers-29.7.0.tgz", + "integrity": "sha512-q4DH1Ha4TTFPdxLsqDXK1d3+ioSL7yL5oCMJZgDYm6i+6CygW5E5xVr/D1HdsGxjt1ZWSfUAs9OxSB/BNelWrQ==", + "dev": true, + "license": "MIT", + "dependencies": { + "@jest/types": "^29.6.3", + "@sinonjs/fake-timers": "^10.0.2", + "@types/node": "*", + "jest-message-util": "^29.7.0", + "jest-mock": "^29.7.0", + "jest-util": "^29.7.0" + }, + "engines": { + "node": "^14.15.0 || ^16.10.0 || >=18.0.0" + } + }, + "node_modules/@jest/globals": { + "version": "29.7.0", + "resolved": "https://registry.npmjs.org/@jest/globals/-/globals-29.7.0.tgz", + "integrity": "sha512-mpiz3dutLbkW2MNFubUGUEVLkTGiqW6yLVTA+JbP6fI6J5iL9Y0Nlg8k95pcF8ctKwCS7WVxteBs29hhfAotzQ==", + "dev": true, + "license": "MIT", + "dependencies": { + "@jest/environment": "^29.7.0", + "@jest/expect": "^29.7.0", + "@jest/types": "^29.6.3", + "jest-mock": "^29.7.0" + }, + "engines": { + "node": "^14.15.0 || ^16.10.0 || >=18.0.0" + } + }, + "node_modules/@jest/reporters": { + "version": "29.7.0", + "resolved": "https://registry.npmjs.org/@jest/reporters/-/reporters-29.7.0.tgz", + "integrity": "sha512-DApq0KJbJOEzAFYjHADNNxAE3KbhxQB1y5Kplb5Waqw6zVbuWatSnMjE5gs8FUgEPmNsnZA3NCWl9NG0ia04Pg==", + "dev": true, + "license": "MIT", + "dependencies": { + "@bcoe/v8-coverage": "^0.2.3", + "@jest/console": "^29.7.0", + "@jest/test-result": "^29.7.0", + "@jest/transform": "^29.7.0", + "@jest/types": "^29.6.3", + "@jridgewell/trace-mapping": "^0.3.18", + "@types/node": "*", + "chalk": "^4.0.0", + "collect-v8-coverage": "^1.0.0", + "exit": "^0.1.2", + "glob": "^7.1.3", + "graceful-fs": "^4.2.9", + "istanbul-lib-coverage": "^3.0.0", + "istanbul-lib-instrument": "^6.0.0", + "istanbul-lib-report": "^3.0.0", + "istanbul-lib-source-maps": "^4.0.0", + "istanbul-reports": "^3.1.3", + "jest-message-util": "^29.7.0", + "jest-util": "^29.7.0", + "jest-worker": "^29.7.0", + "slash": "^3.0.0", + "string-length": "^4.0.1", + "strip-ansi": "^6.0.0", + "v8-to-istanbul": "^9.0.1" + }, + "engines": { + "node": "^14.15.0 || ^16.10.0 || >=18.0.0" + }, + "peerDependencies": { + "node-notifier": "^8.0.1 || ^9.0.0 || ^10.0.0" + }, + "peerDependenciesMeta": { + "node-notifier": { + "optional": true + } + } + }, + "node_modules/@jest/schemas": { + "version": "29.6.3", + "resolved": "https://registry.npmjs.org/@jest/schemas/-/schemas-29.6.3.tgz", + "integrity": "sha512-mo5j5X+jIZmJQveBKeS/clAueipV7KgiX1vMgCxam1RNYiqE1w62n0/tJJnHtjW8ZHcQco5gY85jA3mi0L+nSA==", + "dev": true, + "license": "MIT", + "dependencies": { + "@sinclair/typebox": "^0.27.8" + }, + "engines": { + "node": "^14.15.0 || ^16.10.0 || >=18.0.0" + } + }, + "node_modules/@jest/source-map": { + "version": "29.6.3", + "resolved": "https://registry.npmjs.org/@jest/source-map/-/source-map-29.6.3.tgz", + "integrity": "sha512-MHjT95QuipcPrpLM+8JMSzFx6eHp5Bm+4XeFDJlwsvVBjmKNiIAvasGK2fxz2WbGRlnvqehFbh07MMa7n3YJnw==", + "dev": true, + "license": "MIT", + "dependencies": { + "@jridgewell/trace-mapping": "^0.3.18", + "callsites": "^3.0.0", + "graceful-fs": "^4.2.9" + }, + "engines": { + "node": "^14.15.0 || ^16.10.0 || >=18.0.0" + } + }, + "node_modules/@jest/test-result": { + "version": "29.7.0", + "resolved": "https://registry.npmjs.org/@jest/test-result/-/test-result-29.7.0.tgz", + "integrity": "sha512-Fdx+tv6x1zlkJPcWXmMDAG2HBnaR9XPSd5aDWQVsfrZmLVT3lU1cwyxLgRmXR9yrq4NBoEm9BMsfgFzTQAbJYA==", + "dev": true, + "license": "MIT", + "dependencies": { + "@jest/console": "^29.7.0", + "@jest/types": "^29.6.3", + "@types/istanbul-lib-coverage": "^2.0.0", + "collect-v8-coverage": "^1.0.0" + }, + "engines": { + "node": "^14.15.0 || ^16.10.0 || >=18.0.0" + } + }, + "node_modules/@jest/test-sequencer": { + "version": "29.7.0", + "resolved": "https://registry.npmjs.org/@jest/test-sequencer/-/test-sequencer-29.7.0.tgz", + "integrity": "sha512-GQwJ5WZVrKnOJuiYiAF52UNUJXgTZx1NHjFSEB0qEMmSZKAkdMoIzw/Cj6x6NF4AvV23AUqDpFzQkN/eYCYTxw==", + "dev": true, + "license": "MIT", + "dependencies": { + "@jest/test-result": "^29.7.0", + "graceful-fs": "^4.2.9", + "jest-haste-map": "^29.7.0", + "slash": "^3.0.0" + }, + "engines": { + "node": "^14.15.0 || ^16.10.0 || >=18.0.0" + } + }, + "node_modules/@jest/transform": { + "version": "29.7.0", + "resolved": "https://registry.npmjs.org/@jest/transform/-/transform-29.7.0.tgz", + "integrity": "sha512-ok/BTPFzFKVMwO5eOHRrvnBVHdRy9IrsrW1GpMaQ9MCnilNLXQKmAX8s1YXDFaai9xJpac2ySzV0YeRRECr2Vw==", + "dev": true, + "license": "MIT", + "dependencies": { + "@babel/core": "^7.11.6", + "@jest/types": "^29.6.3", + "@jridgewell/trace-mapping": "^0.3.18", + "babel-plugin-istanbul": "^6.1.1", + "chalk": "^4.0.0", + "convert-source-map": "^2.0.0", + "fast-json-stable-stringify": "^2.1.0", + "graceful-fs": "^4.2.9", + "jest-haste-map": "^29.7.0", + "jest-regex-util": "^29.6.3", + "jest-util": "^29.7.0", + "micromatch": "^4.0.4", + "pirates": "^4.0.4", + "slash": "^3.0.0", + "write-file-atomic": "^4.0.2" + }, + "engines": { + "node": "^14.15.0 || ^16.10.0 || >=18.0.0" + } + }, + "node_modules/@jest/types": { + "version": "29.6.3", + "resolved": "https://registry.npmjs.org/@jest/types/-/types-29.6.3.tgz", + "integrity": "sha512-u3UPsIilWKOM3F9CXtrG8LEJmNxwoCQC/XVj4IKYXvvpx7QIi/Kg1LI5uDmDpKlac62NUtX7eLjRh+jVZcLOzw==", + "dev": true, + "license": "MIT", + "dependencies": { + "@jest/schemas": "^29.6.3", + "@types/istanbul-lib-coverage": "^2.0.0", + "@types/istanbul-reports": "^3.0.0", + "@types/node": "*", + "@types/yargs": "^17.0.8", + "chalk": "^4.0.0" + }, + "engines": { + "node": "^14.15.0 || ^16.10.0 || >=18.0.0" + } + }, + "node_modules/@jridgewell/gen-mapping": { + "version": "0.3.8", + "resolved": "https://registry.npmjs.org/@jridgewell/gen-mapping/-/gen-mapping-0.3.8.tgz", + "integrity": "sha512-imAbBGkb+ebQyxKgzv5Hu2nmROxoDOXHh80evxdoXNOrvAnVx7zimzc1Oo5h9RlfV4vPXaE2iM5pOFbvOCClWA==", + "dev": true, + "license": "MIT", + "dependencies": { + "@jridgewell/set-array": "^1.2.1", + "@jridgewell/sourcemap-codec": "^1.4.10", + "@jridgewell/trace-mapping": "^0.3.24" + }, + "engines": { + "node": ">=6.0.0" + } + }, + "node_modules/@jridgewell/resolve-uri": { + "version": "3.1.2", + "resolved": "https://registry.npmjs.org/@jridgewell/resolve-uri/-/resolve-uri-3.1.2.tgz", + "integrity": "sha512-bRISgCIjP20/tbWSPWMEi54QVPRZExkuD9lJL+UIxUKtwVJA8wW1Trb1jMs1RFXo1CBTNZ/5hpC9QvmKWdopKw==", + "dev": true, + "license": "MIT", + "engines": { + "node": ">=6.0.0" + } + }, + "node_modules/@jridgewell/set-array": { + "version": "1.2.1", + "resolved": "https://registry.npmjs.org/@jridgewell/set-array/-/set-array-1.2.1.tgz", + "integrity": "sha512-R8gLRTZeyp03ymzP/6Lil/28tGeGEzhx1q2k703KGWRAI1VdvPIXdG70VJc2pAMw3NA6JKL5hhFu1sJX0Mnn/A==", + "dev": true, + "license": "MIT", + "engines": { + "node": ">=6.0.0" + } + }, + "node_modules/@jridgewell/sourcemap-codec": { + "version": "1.5.0", + "resolved": "https://registry.npmjs.org/@jridgewell/sourcemap-codec/-/sourcemap-codec-1.5.0.tgz", + "integrity": "sha512-gv3ZRaISU3fjPAgNsriBRqGWQL6quFx04YMPW/zD8XMLsU32mhCCbfbO6KZFLjvYpCZ8zyDEgqsgf+PwPaM7GQ==", + "dev": true, + "license": "MIT" + }, + "node_modules/@jridgewell/trace-mapping": { + "version": "0.3.25", + "resolved": "https://registry.npmjs.org/@jridgewell/trace-mapping/-/trace-mapping-0.3.25.tgz", + "integrity": "sha512-vNk6aEwybGtawWmy/PzwnGDOjCkLWSD2wqvjGGAgOAwCGWySYXfYoxt00IJkTF+8Lb57DwOb3Aa0o9CApepiYQ==", + "dev": true, + "license": "MIT", + "dependencies": { + "@jridgewell/resolve-uri": "^3.1.0", + "@jridgewell/sourcemap-codec": "^1.4.14" + } + }, + "node_modules/@nodelib/fs.scandir": { + "version": "2.1.5", + "resolved": "https://registry.npmjs.org/@nodelib/fs.scandir/-/fs.scandir-2.1.5.tgz", + "integrity": "sha512-vq24Bq3ym5HEQm2NKCr3yXDwjc7vTsEThRDnkp2DK9p1uqLR+DHurm/NOTo0KG7HYHU7eppKZj3MyqYuMBf62g==", + "dev": true, + "license": "MIT", + "dependencies": { + "@nodelib/fs.stat": "2.0.5", + "run-parallel": "^1.1.9" + }, + "engines": { + "node": ">= 8" + } + }, + "node_modules/@nodelib/fs.stat": { + "version": "2.0.5", + "resolved": "https://registry.npmjs.org/@nodelib/fs.stat/-/fs.stat-2.0.5.tgz", + "integrity": "sha512-RkhPPp2zrqDAQA/2jNhnztcPAlv64XdhIp7a7454A5ovI7Bukxgt7MX7udwAu3zg1DcpPU0rz3VV1SeaqvY4+A==", + "dev": true, + "license": "MIT", + "engines": { + "node": ">= 8" + } + }, + "node_modules/@nodelib/fs.walk": { + "version": "1.2.8", + "resolved": "https://registry.npmjs.org/@nodelib/fs.walk/-/fs.walk-1.2.8.tgz", + "integrity": "sha512-oGB+UxlgWcgQkgwo8GcEGwemoTFt3FIO9ababBmaGwXIoBKZ+GTy0pP185beGg7Llih/NSHSV2XAs1lnznocSg==", + "dev": true, + "license": "MIT", + "dependencies": { + "@nodelib/fs.scandir": "2.1.5", + "fastq": "^1.6.0" + }, + "engines": { + "node": ">= 8" + } + }, + "node_modules/@sinclair/typebox": { + "version": "0.27.8", + "resolved": "https://registry.npmjs.org/@sinclair/typebox/-/typebox-0.27.8.tgz", + "integrity": "sha512-+Fj43pSMwJs4KRrH/938Uf+uAELIgVBmQzg/q1YG10djyfA3TnrU8N8XzqCh/okZdszqBQTZf96idMfE5lnwTA==", + "dev": true, + "license": "MIT" + }, + "node_modules/@sindresorhus/is": { + "version": "4.6.0", + "resolved": "https://registry.npmjs.org/@sindresorhus/is/-/is-4.6.0.tgz", + "integrity": "sha512-t09vSN3MdfsyCHoFcTRCH/iUtG7OJ0CsjzB8cjAmKc/va/kIgeDI/TxsigdncE/4be734m0cvIYwNaV4i2XqAw==", + "dev": true, + "license": "MIT", + "engines": { + "node": ">=10" + }, + "funding": { + "url": "https://github.com/sindresorhus/is?sponsor=1" + } + }, + "node_modules/@sinonjs/commons": { + "version": "3.0.1", + "resolved": "https://registry.npmjs.org/@sinonjs/commons/-/commons-3.0.1.tgz", + "integrity": "sha512-K3mCHKQ9sVh8o1C9cxkwxaOmXoAMlDxC1mYyHrjqOWEcBjYr76t96zL2zlj5dUGZ3HSw240X1qgH3Mjf1yJWpQ==", + "dev": true, + "license": "BSD-3-Clause", + "dependencies": { + "type-detect": "4.0.8" + } + }, + "node_modules/@sinonjs/fake-timers": { + "version": "10.3.0", + "resolved": "https://registry.npmjs.org/@sinonjs/fake-timers/-/fake-timers-10.3.0.tgz", + "integrity": "sha512-V4BG07kuYSUkTCSBHG8G8TNhM+F19jXFWnQtzj+we8DrkpSBCee9Z3Ms8yiGer/dlmhe35/Xdgyo3/0rQKg7YA==", + "dev": true, + "license": "BSD-3-Clause", + "dependencies": { + "@sinonjs/commons": "^3.0.0" + } + }, + "node_modules/@szmarczak/http-timer": { + "version": "4.0.6", + "resolved": "https://registry.npmjs.org/@szmarczak/http-timer/-/http-timer-4.0.6.tgz", + "integrity": "sha512-4BAffykYOgO+5nzBWYwE3W90sBgLJoUPRWWcL8wlyiM8IB8ipJz3UMJ9KXQd1RKQXpKp8Tutn80HZtWsu2u76w==", + "dev": true, + "license": "MIT", + "dependencies": { + "defer-to-connect": "^2.0.0" + }, + "engines": { + "node": ">=10" + } + }, + "node_modules/@types/babel__core": { + "version": "7.20.5", + "resolved": "https://registry.npmjs.org/@types/babel__core/-/babel__core-7.20.5.tgz", + "integrity": "sha512-qoQprZvz5wQFJwMDqeseRXWv3rqMvhgpbXFfVyWhbx9X47POIA6i/+dXefEmZKoAgOaTdaIgNSMqMIU61yRyzA==", + "dev": true, + "license": "MIT", + "dependencies": { + "@babel/parser": "^7.20.7", + "@babel/types": "^7.20.7", + "@types/babel__generator": "*", + "@types/babel__template": "*", + "@types/babel__traverse": "*" + } + }, + "node_modules/@types/babel__generator": { + "version": "7.6.8", + "resolved": "https://registry.npmjs.org/@types/babel__generator/-/babel__generator-7.6.8.tgz", + "integrity": "sha512-ASsj+tpEDsEiFr1arWrlN6V3mdfjRMZt6LtK/Vp/kreFLnr5QH5+DhvD5nINYZXzwJvXeGq+05iUXcAzVrqWtw==", + "dev": true, + "license": "MIT", + "dependencies": { + "@babel/types": "^7.0.0" + } + }, + "node_modules/@types/babel__template": { + "version": "7.4.4", + "resolved": "https://registry.npmjs.org/@types/babel__template/-/babel__template-7.4.4.tgz", + "integrity": "sha512-h/NUaSyG5EyxBIp8YRxo4RMe2/qQgvyowRwVMzhYhBCONbW8PUsg4lkFMrhgZhUe5z3L3MiLDuvyJ/CaPa2A8A==", + "dev": true, + "license": "MIT", + "dependencies": { + "@babel/parser": "^7.1.0", + "@babel/types": "^7.0.0" + } + }, + "node_modules/@types/babel__traverse": { + "version": "7.20.7", + "resolved": "https://registry.npmjs.org/@types/babel__traverse/-/babel__traverse-7.20.7.tgz", + "integrity": "sha512-dkO5fhS7+/oos4ciWxyEyjWe48zmG6wbCheo/G2ZnHx4fs3EU6YC6UM8rk56gAjNJ9P3MTH2jo5jb92/K6wbng==", + "dev": true, + "license": "MIT", + "dependencies": { + "@babel/types": "^7.20.7" + } + }, + "node_modules/@types/cacheable-request": { + "version": "6.0.3", + "resolved": "https://registry.npmjs.org/@types/cacheable-request/-/cacheable-request-6.0.3.tgz", + "integrity": "sha512-IQ3EbTzGxIigb1I3qPZc1rWJnH0BmSKv5QYTalEwweFvyBDLSAe24zP0le/hyi7ecGfZVlIVAg4BZqb8WBwKqw==", + "dev": true, + "license": "MIT", + "dependencies": { + "@types/http-cache-semantics": "*", + "@types/keyv": "^3.1.4", + "@types/node": "*", + "@types/responselike": "^1.0.0" + } + }, + "node_modules/@types/estree": { + "version": "1.0.7", + "resolved": "https://registry.npmjs.org/@types/estree/-/estree-1.0.7.tgz", + "integrity": "sha512-w28IoSUCJpidD/TGviZwwMJckNESJZXFu7NBZ5YJ4mEUnNraUn9Pm8HSZm/jDF1pDWYKspWE7oVphigUPRakIQ==", + "dev": true, + "license": "MIT" + }, + "node_modules/@types/graceful-fs": { + "version": "4.1.9", + "resolved": "https://registry.npmjs.org/@types/graceful-fs/-/graceful-fs-4.1.9.tgz", + "integrity": "sha512-olP3sd1qOEe5dXTSaFvQG+02VdRXcdytWLAZsAq1PecU8uqQAhkrnbli7DagjtXKW/Bl7YJbUsa8MPcuc8LHEQ==", + "dev": true, + "license": "MIT", + "dependencies": { + "@types/node": "*" + } + }, + "node_modules/@types/http-cache-semantics": { + "version": "4.0.4", + "resolved": "https://registry.npmjs.org/@types/http-cache-semantics/-/http-cache-semantics-4.0.4.tgz", + "integrity": "sha512-1m0bIFVc7eJWyve9S0RnuRgcQqF/Xd5QsUZAZeQFr1Q3/p9JWoQQEqmVy+DPTNpGXwhgIetAoYF8JSc33q29QA==", + "dev": true, + "license": "MIT" + }, + "node_modules/@types/istanbul-lib-coverage": { + "version": "2.0.6", + "resolved": "https://registry.npmjs.org/@types/istanbul-lib-coverage/-/istanbul-lib-coverage-2.0.6.tgz", + "integrity": "sha512-2QF/t/auWm0lsy8XtKVPG19v3sSOQlJe/YHZgfjb/KBBHOGSV+J2q/S671rcq9uTBrLAXmZpqJiaQbMT+zNU1w==", + "dev": true, + "license": "MIT" + }, + "node_modules/@types/istanbul-lib-report": { + "version": "3.0.3", + "resolved": "https://registry.npmjs.org/@types/istanbul-lib-report/-/istanbul-lib-report-3.0.3.tgz", + "integrity": "sha512-NQn7AHQnk/RSLOxrBbGyJM/aVQ+pjj5HCgasFxc0K/KhoATfQ/47AyUl15I2yBUpihjmas+a+VJBOqecrFH+uA==", + "dev": true, + "license": "MIT", + "dependencies": { + "@types/istanbul-lib-coverage": "*" + } + }, + "node_modules/@types/istanbul-reports": { + "version": "3.0.4", + "resolved": "https://registry.npmjs.org/@types/istanbul-reports/-/istanbul-reports-3.0.4.tgz", + "integrity": "sha512-pk2B1NWalF9toCRu6gjBzR69syFjP4Od8WRAX+0mmf9lAjCRicLOWc+ZrxZHx/0XRjotgkF9t6iaMJ+aXcOdZQ==", + "dev": true, + "license": "MIT", + "dependencies": { + "@types/istanbul-lib-report": "*" + } + }, + "node_modules/@types/json-schema": { + "version": "7.0.15", + "resolved": "https://registry.npmjs.org/@types/json-schema/-/json-schema-7.0.15.tgz", + "integrity": "sha512-5+fP8P8MFNC+AyZCDxrB2pkZFPGzqQWUzpSeuuVLvm8VMcorNYavBqoFcxK8bQz4Qsbn4oUEEem4wDLfcysGHA==", + "dev": true, + "license": "MIT" + }, + "node_modules/@types/keyv": { + "version": "3.1.4", + "resolved": "https://registry.npmjs.org/@types/keyv/-/keyv-3.1.4.tgz", + "integrity": "sha512-BQ5aZNSCpj7D6K2ksrRCTmKRLEpnPvWDiLPfoGyhZ++8YtiK9d/3DBKPJgry359X/P1PfruyYwvnvwFjuEiEIg==", + "dev": true, + "license": "MIT", + "dependencies": { + "@types/node": "*" + } + }, + "node_modules/@types/node": { + "version": "22.13.13", + "resolved": "https://registry.npmjs.org/@types/node/-/node-22.13.13.tgz", + "integrity": "sha512-ClsL5nMwKaBRwPcCvH8E7+nU4GxHVx1axNvMZTFHMEfNI7oahimt26P5zjVCRrjiIWj6YFXfE1v3dEp94wLcGQ==", + "dev": true, + "license": "MIT", + "dependencies": { + "undici-types": "~6.20.0" + } + }, + "node_modules/@types/responselike": { + "version": "1.0.3", + "resolved": "https://registry.npmjs.org/@types/responselike/-/responselike-1.0.3.tgz", + "integrity": "sha512-H/+L+UkTV33uf49PH5pCAUBVPNj2nDBXTN+qS1dOwyyg24l3CcicicCA7ca+HMvJBZcFgl5r8e+RR6elsb4Lyw==", + "dev": true, + "license": "MIT", + "dependencies": { + "@types/node": "*" + } + }, + "node_modules/@types/stack-utils": { + "version": "2.0.3", + "resolved": "https://registry.npmjs.org/@types/stack-utils/-/stack-utils-2.0.3.tgz", + "integrity": "sha512-9aEbYZ3TbYMznPdcdr3SmIrLXwC/AKZXQeCf9Pgao5CKb8CyHuEX5jzWPTkvregvhRJHcpRO6BFoGW9ycaOkYw==", + "dev": true, + "license": "MIT" + }, + "node_modules/@types/yargs": { + "version": "17.0.33", + "resolved": "https://registry.npmjs.org/@types/yargs/-/yargs-17.0.33.tgz", + "integrity": "sha512-WpxBCKWPLr4xSsHgz511rFJAM+wS28w2zEO1QDNY5zM/S8ok70NNfztH0xwhqKyaK0OHCbN98LDAZuy1ctxDkA==", + "dev": true, + "license": "MIT", + "dependencies": { + "@types/yargs-parser": "*" + } + }, + "node_modules/@types/yargs-parser": { + "version": "21.0.3", + "resolved": "https://registry.npmjs.org/@types/yargs-parser/-/yargs-parser-21.0.3.tgz", + "integrity": "sha512-I4q9QU9MQv4oEOz4tAHJtNz1cwuLxn2F3xcc2iV5WdqLPpUnj30aUuxt1mAxYTG+oe8CZMV/+6rU4S4gRDzqtQ==", + "dev": true, + "license": "MIT" + }, + "node_modules/@typescript-eslint/scope-manager": { + "version": "8.29.0", + "resolved": "https://registry.npmjs.org/@typescript-eslint/scope-manager/-/scope-manager-8.29.0.tgz", + "integrity": "sha512-aO1PVsq7Gm+tcghabUpzEnVSFMCU4/nYIgC2GOatJcllvWfnhrgW0ZEbnTxm36QsikmCN1K/6ZgM7fok2I7xNw==", + "dev": true, + "license": "MIT", + "dependencies": { + "@typescript-eslint/types": "8.29.0", + "@typescript-eslint/visitor-keys": "8.29.0" + }, + "engines": { + "node": "^18.18.0 || ^20.9.0 || >=21.1.0" + }, + "funding": { + "type": "opencollective", + "url": "https://opencollective.com/typescript-eslint" + } + }, + "node_modules/@typescript-eslint/types": { + "version": "8.29.0", + "resolved": "https://registry.npmjs.org/@typescript-eslint/types/-/types-8.29.0.tgz", + "integrity": "sha512-wcJL/+cOXV+RE3gjCyl/V2G877+2faqvlgtso/ZRbTCnZazh0gXhe+7gbAnfubzN2bNsBtZjDvlh7ero8uIbzg==", + "dev": true, + "license": "MIT", + "engines": { + "node": "^18.18.0 || ^20.9.0 || >=21.1.0" + }, + "funding": { + "type": "opencollective", + "url": "https://opencollective.com/typescript-eslint" + } + }, + "node_modules/@typescript-eslint/typescript-estree": { + "version": "8.29.0", + "resolved": "https://registry.npmjs.org/@typescript-eslint/typescript-estree/-/typescript-estree-8.29.0.tgz", + "integrity": "sha512-yOfen3jE9ISZR/hHpU/bmNvTtBW1NjRbkSFdZOksL1N+ybPEE7UVGMwqvS6CP022Rp00Sb0tdiIkhSCe6NI8ow==", + "dev": true, + "license": "MIT", + "dependencies": { + "@typescript-eslint/types": "8.29.0", + "@typescript-eslint/visitor-keys": "8.29.0", + "debug": "^4.3.4", + "fast-glob": "^3.3.2", + "is-glob": "^4.0.3", + "minimatch": "^9.0.4", + "semver": "^7.6.0", + "ts-api-utils": "^2.0.1" + }, + "engines": { + "node": "^18.18.0 || ^20.9.0 || >=21.1.0" + }, + "funding": { + "type": "opencollective", + "url": "https://opencollective.com/typescript-eslint" + }, + "peerDependencies": { + "typescript": ">=4.8.4 <5.9.0" + } + }, + "node_modules/@typescript-eslint/typescript-estree/node_modules/brace-expansion": { + "version": "2.0.2", + "resolved": "https://registry.npmjs.org/brace-expansion/-/brace-expansion-2.0.2.tgz", + "integrity": "sha512-Jt0vHyM+jmUBqojB7E1NIYadt0vI0Qxjxd2TErW94wDz+E2LAm5vKMXXwg6ZZBTHPuUlDgQHKXvjGBdfcF1ZDQ==", + "dev": true, + "license": "MIT", + "dependencies": { + "balanced-match": "^1.0.0" + } + }, + "node_modules/@typescript-eslint/typescript-estree/node_modules/minimatch": { + "version": "9.0.5", + "resolved": "https://registry.npmjs.org/minimatch/-/minimatch-9.0.5.tgz", + "integrity": "sha512-G6T0ZX48xgozx7587koeX9Ys2NYy6Gmv//P89sEte9V9whIapMNF4idKxnW2QtCcLiTWlb/wfCabAtAFWhhBow==", + "dev": true, + "license": "ISC", + "dependencies": { + "brace-expansion": "^2.0.1" + }, + "engines": { + "node": ">=16 || 14 >=14.17" + }, + "funding": { + "url": "https://github.com/sponsors/isaacs" + } + }, + "node_modules/@typescript-eslint/typescript-estree/node_modules/semver": { + "version": "7.7.1", + "resolved": "https://registry.npmjs.org/semver/-/semver-7.7.1.tgz", + "integrity": "sha512-hlq8tAfn0m/61p4BVRcPzIGr6LKiMwo4VM6dGi6pt4qcRkmNzTcWq6eCEjEh+qXjkMDvPlOFFSGwQjoEa6gyMA==", + "dev": true, + "license": "ISC", + "bin": { + "semver": "bin/semver.js" + }, + "engines": { + "node": ">=10" + } + }, + "node_modules/@typescript-eslint/utils": { + "version": "8.29.0", + "resolved": "https://registry.npmjs.org/@typescript-eslint/utils/-/utils-8.29.0.tgz", + "integrity": "sha512-gX/A0Mz9Bskm8avSWFcK0gP7cZpbY4AIo6B0hWYFCaIsz750oaiWR4Jr2CI+PQhfW1CpcQr9OlfPS+kMFegjXA==", + "dev": true, + "license": "MIT", + "dependencies": { + "@eslint-community/eslint-utils": "^4.4.0", + "@typescript-eslint/scope-manager": "8.29.0", + "@typescript-eslint/types": "8.29.0", + "@typescript-eslint/typescript-estree": "8.29.0" + }, + "engines": { + "node": "^18.18.0 || ^20.9.0 || >=21.1.0" + }, + "funding": { + "type": "opencollective", + "url": "https://opencollective.com/typescript-eslint" + }, + "peerDependencies": { + "eslint": "^8.57.0 || ^9.0.0", + "typescript": ">=4.8.4 <5.9.0" + } + }, + "node_modules/@typescript-eslint/visitor-keys": { + "version": "8.29.0", + "resolved": "https://registry.npmjs.org/@typescript-eslint/visitor-keys/-/visitor-keys-8.29.0.tgz", + "integrity": "sha512-Sne/pVz8ryR03NFK21VpN88dZ2FdQXOlq3VIklbrTYEt8yXtRFr9tvUhqvCeKjqYk5FSim37sHbooT6vzBTZcg==", + "dev": true, + "license": "MIT", + "dependencies": { + "@typescript-eslint/types": "8.29.0", + "eslint-visitor-keys": "^4.2.0" + }, + "engines": { + "node": "^18.18.0 || ^20.9.0 || >=21.1.0" + }, + "funding": { + "type": "opencollective", + "url": "https://opencollective.com/typescript-eslint" + } + }, + "node_modules/acorn": { + "version": "8.15.0", + "resolved": "https://registry.npmjs.org/acorn/-/acorn-8.15.0.tgz", + "integrity": "sha512-NZyJarBfL7nWwIq+FDL6Zp/yHEhePMNnnJ0y3qfieCrmNvYct8uvtiV41UvlSe6apAfk0fY1FbWx+NwfmpvtTg==", + "dev": true, + "license": "MIT", + "bin": { + "acorn": "bin/acorn" + }, + "engines": { + "node": ">=0.4.0" + } + }, + "node_modules/acorn-jsx": { + "version": "5.3.2", + "resolved": "https://registry.npmjs.org/acorn-jsx/-/acorn-jsx-5.3.2.tgz", + "integrity": "sha512-rq9s+JNhf0IChjtDXxllJ7g41oZk5SlXtp0LHwyA5cejwn7vKmKp4pPri6YEePv2PU65sAsegbXtIinmDFDXgQ==", + "dev": true, + "license": "MIT", + "peerDependencies": { + "acorn": "^6.0.0 || ^7.0.0 || ^8.0.0" + } + }, + "node_modules/adm-zip": { + "version": "0.5.16", + "resolved": "https://registry.npmjs.org/adm-zip/-/adm-zip-0.5.16.tgz", + "integrity": "sha512-TGw5yVi4saajsSEgz25grObGHEUaDrniwvA2qwSC060KfqGPdglhvPMA2lPIoxs3PQIItj2iag35fONcQqgUaQ==", + "license": "MIT", + "engines": { + "node": ">=12.0" + } + }, + "node_modules/ajv": { + "version": "6.12.6", + "resolved": "https://registry.npmjs.org/ajv/-/ajv-6.12.6.tgz", + "integrity": "sha512-j3fVLgvTo527anyYyJOGTYJbG+vnnQYvE0m5mmkc1TK+nxAppkCLMIL0aZ4dblVCNoGShhm+kzE4ZUykBoMg4g==", + "dev": true, + "license": "MIT", + "dependencies": { + "fast-deep-equal": "^3.1.1", + "fast-json-stable-stringify": "^2.0.0", + "json-schema-traverse": "^0.4.1", + "uri-js": "^4.2.2" + }, + "funding": { + "type": "github", + "url": "https://github.com/sponsors/epoberezkin" + } + }, + "node_modules/ansi-escapes": { + "version": "4.3.2", + "resolved": "https://registry.npmjs.org/ansi-escapes/-/ansi-escapes-4.3.2.tgz", + "integrity": "sha512-gKXj5ALrKWQLsYG9jlTRmR/xKluxHV+Z9QEwNIgCfM1/uwPMCuzVVnh5mwTd+OuBZcwSIMbqssNWRm1lE51QaQ==", + "dev": true, + "license": "MIT", + "dependencies": { + "type-fest": "^0.21.3" + }, + "engines": { + "node": ">=8" + }, + "funding": { + "url": "https://github.com/sponsors/sindresorhus" + } + }, + "node_modules/ansi-regex": { + "version": "5.0.1", + "resolved": "https://registry.npmjs.org/ansi-regex/-/ansi-regex-5.0.1.tgz", + "integrity": "sha512-quJQXlTSUGL2LH9SUXo8VwsY4soanhgo6LNSm84E1LBcE8s3O0wpdiRzyR9z/ZZJMlMWv37qOOb9pdJlMUEKFQ==", + "dev": true, + "license": "MIT", + "engines": { + "node": ">=8" + } + }, + "node_modules/ansi-styles": { + "version": "4.3.0", + "resolved": "https://registry.npmjs.org/ansi-styles/-/ansi-styles-4.3.0.tgz", + "integrity": "sha512-zbB9rCJAT1rbjiVDb2hqKFHNYLxgtk8NURxZ3IZwD3F6NtxbXZQCnnSi1Lkx+IDohdPlFp222wVALIheZJQSEg==", + "dev": true, + "license": "MIT", + "dependencies": { + "color-convert": "^2.0.1" + }, + "engines": { + "node": ">=8" + }, + "funding": { + "url": "https://github.com/chalk/ansi-styles?sponsor=1" + } + }, + "node_modules/anymatch": { + "version": "3.1.3", + "resolved": "https://registry.npmjs.org/anymatch/-/anymatch-3.1.3.tgz", + "integrity": "sha512-KMReFUr0B4t+D+OBkjR3KYqvocp2XaSzO55UcB6mgQMd3KbcE+mWTyvVV7D/zsdEbNnV6acZUutkiHQXvTr1Rw==", + "dev": true, + "license": "ISC", + "dependencies": { + "normalize-path": "^3.0.0", + "picomatch": "^2.0.4" + }, + "engines": { + "node": ">= 8" + } + }, + "node_modules/arg": { + "version": "4.1.3", + "resolved": "https://registry.npmjs.org/arg/-/arg-4.1.3.tgz", + "integrity": "sha512-58S9QDqG0Xx27YwPSt9fJxivjYl432YCwfDMfZ+71RAqUrZef7LrKQZ3LHLOwCS4FLNBplP533Zx895SeOCHvA==", + "dev": true, + "license": "MIT" + }, + "node_modules/argparse": { + "version": "1.0.10", + "resolved": "https://registry.npmjs.org/argparse/-/argparse-1.0.10.tgz", + "integrity": "sha512-o5Roy6tNG4SL/FOkCAN6RzjiakZS25RLYFrcMttJqbdd8BWrnA+fGz57iN5Pb06pvBGvl5gQ0B48dJlslXvoTg==", + "dev": true, + "license": "MIT", + "dependencies": { + "sprintf-js": "~1.0.2" + } + }, + "node_modules/array-buffer-byte-length": { + "version": "1.0.2", + "resolved": "https://registry.npmjs.org/array-buffer-byte-length/-/array-buffer-byte-length-1.0.2.tgz", + "integrity": "sha512-LHE+8BuR7RYGDKvnrmcuSq3tDcKv9OFEXQt/HpbZhY7V6h0zlUXutnAD82GiFx9rdieCMjkvtcsPqBwgUl1Iiw==", + "dev": true, + "license": "MIT", + "dependencies": { + "call-bound": "^1.0.3", + "is-array-buffer": "^3.0.5" + }, + "engines": { + "node": ">= 0.4" + }, + "funding": { + "url": "https://github.com/sponsors/ljharb" + } + }, + "node_modules/arraybuffer.prototype.slice": { + "version": "1.0.4", + "resolved": "https://registry.npmjs.org/arraybuffer.prototype.slice/-/arraybuffer.prototype.slice-1.0.4.tgz", + "integrity": "sha512-BNoCY6SXXPQ7gF2opIP4GBE+Xw7U+pHMYKuzjgCN3GwiaIR09UUeKfheyIry77QtrCBlC0KK0q5/TER/tYh3PQ==", + "dev": true, + "license": "MIT", + "dependencies": { + "array-buffer-byte-length": "^1.0.1", + "call-bind": "^1.0.8", + "define-properties": "^1.2.1", + "es-abstract": "^1.23.5", + "es-errors": "^1.3.0", + "get-intrinsic": "^1.2.6", + "is-array-buffer": "^3.0.4" + }, + "engines": { + "node": ">= 0.4" + }, + "funding": { + "url": "https://github.com/sponsors/ljharb" + } + }, + "node_modules/async-function": { + "version": "1.0.0", + "resolved": "https://registry.npmjs.org/async-function/-/async-function-1.0.0.tgz", + "integrity": "sha512-hsU18Ae8CDTR6Kgu9DYf0EbCr/a5iGL0rytQDobUcdpYOKokk8LEjVphnXkDkgpi0wYVsqrXuP0bZxJaTqdgoA==", + "dev": true, + "license": "MIT", + "engines": { + "node": ">= 0.4" + } + }, + "node_modules/asynckit": { + "version": "0.4.0", + "resolved": "https://registry.npmjs.org/asynckit/-/asynckit-0.4.0.tgz", + "integrity": "sha512-Oei9OH4tRh0YqU3GxhX79dM/mwVgvbZJaSNaRk+bshkj0S5cfHcgYakreBjrHwatXKbz+IoIdYLxrKim2MjW0Q==", + "license": "MIT" + }, + "node_modules/available-typed-arrays": { + "version": "1.0.7", + "resolved": "https://registry.npmjs.org/available-typed-arrays/-/available-typed-arrays-1.0.7.tgz", + "integrity": "sha512-wvUjBtSGN7+7SjNpq/9M2Tg350UZD3q62IFZLbRAR1bSMlCo1ZaeW+BJ+D090e4hIIZLBcTDWe4Mh4jvUDajzQ==", + "dev": true, + "license": "MIT", + "dependencies": { + "possible-typed-array-names": "^1.0.0" + }, + "engines": { + "node": ">= 0.4" + }, + "funding": { + "url": "https://github.com/sponsors/ljharb" + } + }, + "node_modules/babel-jest": { + "version": "29.7.0", + "resolved": "https://registry.npmjs.org/babel-jest/-/babel-jest-29.7.0.tgz", + "integrity": "sha512-BrvGY3xZSwEcCzKvKsCi2GgHqDqsYkOP4/by5xCgIwGXQxIEh+8ew3gmrE1y7XRR6LHZIj6yLYnUi/mm2KXKBg==", + "dev": true, + "license": "MIT", + "dependencies": { + "@jest/transform": "^29.7.0", + "@types/babel__core": "^7.1.14", + "babel-plugin-istanbul": "^6.1.1", + "babel-preset-jest": "^29.6.3", + "chalk": "^4.0.0", + "graceful-fs": "^4.2.9", + "slash": "^3.0.0" + }, + "engines": { + "node": "^14.15.0 || ^16.10.0 || >=18.0.0" + }, + "peerDependencies": { + "@babel/core": "^7.8.0" + } + }, + "node_modules/babel-plugin-istanbul": { + "version": "6.1.1", + "resolved": "https://registry.npmjs.org/babel-plugin-istanbul/-/babel-plugin-istanbul-6.1.1.tgz", + "integrity": "sha512-Y1IQok9821cC9onCx5otgFfRm7Lm+I+wwxOx738M/WLPZ9Q42m4IG5W0FNX8WLL2gYMZo3JkuXIH2DOpWM+qwA==", + "dev": true, + "license": "BSD-3-Clause", + "dependencies": { + "@babel/helper-plugin-utils": "^7.0.0", + "@istanbuljs/load-nyc-config": "^1.0.0", + "@istanbuljs/schema": "^0.1.2", + "istanbul-lib-instrument": "^5.0.4", + "test-exclude": "^6.0.0" + }, + "engines": { + "node": ">=8" + } + }, + "node_modules/babel-plugin-istanbul/node_modules/istanbul-lib-instrument": { + "version": "5.2.1", + "resolved": "https://registry.npmjs.org/istanbul-lib-instrument/-/istanbul-lib-instrument-5.2.1.tgz", + "integrity": "sha512-pzqtp31nLv/XFOzXGuvhCb8qhjmTVo5vjVk19XE4CRlSWz0KoeJ3bw9XsA7nOp9YBf4qHjwBxkDzKcME/J29Yg==", + "dev": true, + "license": "BSD-3-Clause", + "dependencies": { + "@babel/core": "^7.12.3", + "@babel/parser": "^7.14.7", + "@istanbuljs/schema": "^0.1.2", + "istanbul-lib-coverage": "^3.2.0", + "semver": "^6.3.0" + }, + "engines": { + "node": ">=8" + } + }, + "node_modules/babel-plugin-jest-hoist": { + "version": "29.6.3", + "resolved": "https://registry.npmjs.org/babel-plugin-jest-hoist/-/babel-plugin-jest-hoist-29.6.3.tgz", + "integrity": "sha512-ESAc/RJvGTFEzRwOTT4+lNDk/GNHMkKbNzsvT0qKRfDyyYTskxB5rnU2njIDYVxXCBHHEI1c0YwHob3WaYujOg==", + "dev": true, + "license": "MIT", + "dependencies": { + "@babel/template": "^7.3.3", + "@babel/types": "^7.3.3", + "@types/babel__core": "^7.1.14", + "@types/babel__traverse": "^7.0.6" + }, + "engines": { + "node": "^14.15.0 || ^16.10.0 || >=18.0.0" + } + }, + "node_modules/babel-preset-current-node-syntax": { + "version": "1.1.0", + "resolved": "https://registry.npmjs.org/babel-preset-current-node-syntax/-/babel-preset-current-node-syntax-1.1.0.tgz", + "integrity": "sha512-ldYss8SbBlWva1bs28q78Ju5Zq1F+8BrqBZZ0VFhLBvhh6lCpC2o3gDJi/5DRLs9FgYZCnmPYIVFU4lRXCkyUw==", + "dev": true, + "license": "MIT", + "dependencies": { + "@babel/plugin-syntax-async-generators": "^7.8.4", + "@babel/plugin-syntax-bigint": "^7.8.3", + "@babel/plugin-syntax-class-properties": "^7.12.13", + "@babel/plugin-syntax-class-static-block": "^7.14.5", + "@babel/plugin-syntax-import-attributes": "^7.24.7", + "@babel/plugin-syntax-import-meta": "^7.10.4", + "@babel/plugin-syntax-json-strings": "^7.8.3", + "@babel/plugin-syntax-logical-assignment-operators": "^7.10.4", + "@babel/plugin-syntax-nullish-coalescing-operator": "^7.8.3", + "@babel/plugin-syntax-numeric-separator": "^7.10.4", + "@babel/plugin-syntax-object-rest-spread": "^7.8.3", + "@babel/plugin-syntax-optional-catch-binding": "^7.8.3", + "@babel/plugin-syntax-optional-chaining": "^7.8.3", + "@babel/plugin-syntax-private-property-in-object": "^7.14.5", + "@babel/plugin-syntax-top-level-await": "^7.14.5" + }, + "peerDependencies": { + "@babel/core": "^7.0.0" + } + }, + "node_modules/babel-preset-jest": { + "version": "29.6.3", + "resolved": "https://registry.npmjs.org/babel-preset-jest/-/babel-preset-jest-29.6.3.tgz", + "integrity": "sha512-0B3bhxR6snWXJZtR/RliHTDPRgn1sNHOR0yVtq/IiQFyuOVjFS+wuio/R4gSNkyYmKmJB4wGZv2NZanmKmTnNA==", + "dev": true, + "license": "MIT", + "dependencies": { + "babel-plugin-jest-hoist": "^29.6.3", + "babel-preset-current-node-syntax": "^1.0.0" + }, + "engines": { + "node": "^14.15.0 || ^16.10.0 || >=18.0.0" + }, + "peerDependencies": { + "@babel/core": "^7.0.0" + } + }, + "node_modules/balanced-match": { + "version": "1.0.2", + "resolved": "https://registry.npmjs.org/balanced-match/-/balanced-match-1.0.2.tgz", + "integrity": "sha512-3oSeUO0TMV67hN1AmbXsK4yaqU7tjiHlbxRDZOpH0KW9+CeX4bRAaX0Anxt0tx2MrpRpWwQaPwIlISEJhYU5Pw==", + "dev": true, + "license": "MIT" + }, + "node_modules/base64-js": { + "version": "1.5.1", + "resolved": "https://registry.npmjs.org/base64-js/-/base64-js-1.5.1.tgz", + "integrity": "sha512-AKpaYlHn8t4SVbOHCy+b5+KKgvR4vrsD8vbvrbiQJps7fKDTkjkDry6ji0rUJjC0kzbNePLwzxq8iypo41qeWA==", + "dev": true, + "funding": [ + { + "type": "github", + "url": "https://github.com/sponsors/feross" + }, + { + "type": "patreon", + "url": "https://www.patreon.com/feross" + }, + { + "type": "consulting", + "url": "https://feross.org/support" + } + ], + "license": "MIT" + }, + "node_modules/binary-extensions": { + "version": "2.3.0", + "resolved": "https://registry.npmjs.org/binary-extensions/-/binary-extensions-2.3.0.tgz", + "integrity": "sha512-Ceh+7ox5qe7LJuLHoY0feh3pHuUDHAcRUeyL2VYghZwfpkNIy/+8Ocg0a3UuSoYzavmylwuLWQOf3hl0jjMMIw==", + "dev": true, + "license": "MIT", + "engines": { + "node": ">=8" + }, + "funding": { + "url": "https://github.com/sponsors/sindresorhus" + } + }, + "node_modules/bl": { + "version": "4.1.0", + "resolved": "https://registry.npmjs.org/bl/-/bl-4.1.0.tgz", + "integrity": "sha512-1W07cM9gS6DcLperZfFSj+bWLtaPGSOHWhPiGzXmvVJbRLdG82sH/Kn8EtW1VqWVA54AKf2h5k5BbnIbwF3h6w==", + "dev": true, + "license": "MIT", + "dependencies": { + "buffer": "^5.5.0", + "inherits": "^2.0.4", + "readable-stream": "^3.4.0" + } + }, + "node_modules/brace-expansion": { + "version": "1.1.12", + "resolved": "https://registry.npmjs.org/brace-expansion/-/brace-expansion-1.1.12.tgz", + "integrity": "sha512-9T9UjW3r0UW5c1Q7GTwllptXwhvYmEzFhzMfZ9H7FQWt+uZePjZPjBP/W1ZEyZ1twGWom5/56TF4lPcqjnDHcg==", + "dev": true, + "license": "MIT", + "dependencies": { + "balanced-match": "^1.0.0", + "concat-map": "0.0.1" + } + }, + "node_modules/braces": { + "version": "3.0.3", + "resolved": "https://registry.npmjs.org/braces/-/braces-3.0.3.tgz", + "integrity": "sha512-yQbXgO/OSZVD2IsiLlro+7Hf6Q18EJrKSEsdoMzKePKXct3gvD8oLcOQdIzGupr5Fj+EDe8gO/lxc1BzfMpxvA==", + "dev": true, + "license": "MIT", + "dependencies": { + "fill-range": "^7.1.1" + }, + "engines": { + "node": ">=8" + } + }, + "node_modules/browserslist": { + "version": "4.24.4", + "resolved": "https://registry.npmjs.org/browserslist/-/browserslist-4.24.4.tgz", + "integrity": "sha512-KDi1Ny1gSePi1vm0q4oxSF8b4DR44GF4BbmS2YdhPLOEqd8pDviZOGH/GsmRwoWJ2+5Lr085X7naowMwKHDG1A==", + "dev": true, + "funding": [ + { + "type": "opencollective", + "url": "https://opencollective.com/browserslist" + }, + { + "type": "tidelift", + "url": "https://tidelift.com/funding/github/npm/browserslist" + }, + { + "type": "github", + "url": "https://github.com/sponsors/ai" + } + ], + "license": "MIT", + "dependencies": { + "caniuse-lite": "^1.0.30001688", + "electron-to-chromium": "^1.5.73", + "node-releases": "^2.0.19", + "update-browserslist-db": "^1.1.1" + }, + "bin": { + "browserslist": "cli.js" + }, + "engines": { + "node": "^6 || ^7 || ^8 || ^9 || ^10 || ^11 || ^12 || >=13.7" + } + }, + "node_modules/bser": { + "version": "2.1.1", + "resolved": "https://registry.npmjs.org/bser/-/bser-2.1.1.tgz", + "integrity": "sha512-gQxTNE/GAfIIrmHLUE3oJyp5FO6HRBfhjnw4/wMmA63ZGDJnWBmgY/lyQBpnDUkGmAhbSe39tx2d/iTOAfglwQ==", + "dev": true, + "license": "Apache-2.0", + "dependencies": { + "node-int64": "^0.4.0" + } + }, + "node_modules/buffer": { + "version": "5.7.1", + "resolved": "https://registry.npmjs.org/buffer/-/buffer-5.7.1.tgz", + "integrity": "sha512-EHcyIPBQ4BSGlvjB16k5KgAJ27CIsHY/2JBmCRReo48y9rQ3MaUzWX3KVlBa4U7MyX02HdVj0K7C3WaB3ju7FQ==", + "dev": true, + "funding": [ + { + "type": "github", + "url": "https://github.com/sponsors/feross" + }, + { + "type": "patreon", + "url": "https://www.patreon.com/feross" + }, + { + "type": "consulting", + "url": "https://feross.org/support" + } + ], + "license": "MIT", + "dependencies": { + "base64-js": "^1.3.1", + "ieee754": "^1.1.13" + } + }, + "node_modules/buffer-from": { + "version": "1.1.2", + "resolved": "https://registry.npmjs.org/buffer-from/-/buffer-from-1.1.2.tgz", + "integrity": "sha512-E+XQCRwSbaaiChtv6k6Dwgc+bx+Bs6vuKJHHl5kox/BaKbhiXzqQOwK4cO22yElGp2OCmjwVhT3HmxgyPGnJfQ==", + "dev": true, + "license": "MIT" + }, + "node_modules/cacheable-lookup": { + "version": "5.0.4", + "resolved": "https://registry.npmjs.org/cacheable-lookup/-/cacheable-lookup-5.0.4.tgz", + "integrity": "sha512-2/kNscPhpcxrOigMZzbiWF7dz8ilhb/nIHU3EyZiXWXpeq/au8qJ8VhdftMkty3n7Gj6HIGalQG8oiBNB3AJgA==", + "dev": true, + "license": "MIT", + "engines": { + "node": ">=10.6.0" + } + }, + "node_modules/cacheable-request": { + "version": "7.0.4", + "resolved": "https://registry.npmjs.org/cacheable-request/-/cacheable-request-7.0.4.tgz", + "integrity": "sha512-v+p6ongsrp0yTGbJXjgxPow2+DL93DASP4kXCDKb8/bwRtt9OEF3whggkkDkGNzgcWy2XaF4a8nZglC7uElscg==", + "dev": true, + "license": "MIT", + "dependencies": { + "clone-response": "^1.0.2", + "get-stream": "^5.1.0", + "http-cache-semantics": "^4.0.0", + "keyv": "^4.0.0", + "lowercase-keys": "^2.0.0", + "normalize-url": "^6.0.1", + "responselike": "^2.0.0" + }, + "engines": { + "node": ">=8" + } + }, + "node_modules/call-bind": { + "version": "1.0.8", + "resolved": "https://registry.npmjs.org/call-bind/-/call-bind-1.0.8.tgz", + "integrity": "sha512-oKlSFMcMwpUg2ednkhQ454wfWiU/ul3CkJe/PEHcTKuiX6RpbehUiFMXu13HalGZxfUwCQzZG747YXBn1im9ww==", + "dev": true, + "license": "MIT", + "dependencies": { + "call-bind-apply-helpers": "^1.0.0", + "es-define-property": "^1.0.0", + "get-intrinsic": "^1.2.4", + "set-function-length": "^1.2.2" + }, + "engines": { + "node": ">= 0.4" + }, + "funding": { + "url": "https://github.com/sponsors/ljharb" + } + }, + "node_modules/call-bind-apply-helpers": { + "version": "1.0.2", + "resolved": "https://registry.npmjs.org/call-bind-apply-helpers/-/call-bind-apply-helpers-1.0.2.tgz", + "integrity": "sha512-Sp1ablJ0ivDkSzjcaJdxEunN5/XvksFJ2sMBFfq6x0ryhQV/2b/KwFe21cMpmHtPOSij8K99/wSfoEuTObmuMQ==", + "license": "MIT", + "dependencies": { + "es-errors": "^1.3.0", + "function-bind": "^1.1.2" + }, + "engines": { + "node": ">= 0.4" + } + }, + "node_modules/call-bound": { + "version": "1.0.4", + "resolved": "https://registry.npmjs.org/call-bound/-/call-bound-1.0.4.tgz", + "integrity": "sha512-+ys997U96po4Kx/ABpBCqhA9EuxJaQWDQg7295H4hBphv3IZg0boBKuwYpt4YXp6MZ5AmZQnU/tyMTlRpaSejg==", + "dev": true, + "license": "MIT", + "dependencies": { + "call-bind-apply-helpers": "^1.0.2", + "get-intrinsic": "^1.3.0" + }, + "engines": { + "node": ">= 0.4" + }, + "funding": { + "url": "https://github.com/sponsors/ljharb" + } + }, + "node_modules/callsites": { + "version": "3.1.0", + "resolved": "https://registry.npmjs.org/callsites/-/callsites-3.1.0.tgz", + "integrity": "sha512-P8BjAsXvZS+VIDUI11hHCQEv74YT67YUi5JJFNWIqL235sBmjX4+qx9Muvls5ivyNENctx46xQLQ3aTuE7ssaQ==", + "dev": true, + "license": "MIT", + "engines": { + "node": ">=6" + } + }, + "node_modules/camelcase": { + "version": "5.3.1", + "resolved": "https://registry.npmjs.org/camelcase/-/camelcase-5.3.1.tgz", + "integrity": "sha512-L28STB170nwWS63UjtlEOE3dldQApaJXZkOI1uMFfzf3rRuPegHaHesyee+YxQ+W6SvRDQV6UrdOdRiR153wJg==", + "dev": true, + "license": "MIT", + "engines": { + "node": ">=6" + } + }, + "node_modules/caniuse-lite": { + "version": "1.0.30001707", + "resolved": "https://registry.npmjs.org/caniuse-lite/-/caniuse-lite-1.0.30001707.tgz", + "integrity": "sha512-3qtRjw/HQSMlDWf+X79N206fepf4SOOU6SQLMaq/0KkZLmSjPxAkBOQQ+FxbHKfHmYLZFfdWsO3KA90ceHPSnw==", + "dev": true, + "funding": [ + { + "type": "opencollective", + "url": "https://opencollective.com/browserslist" + }, + { + "type": "tidelift", + "url": "https://tidelift.com/funding/github/npm/caniuse-lite" + }, + { + "type": "github", + "url": "https://github.com/sponsors/ai" + } + ], + "license": "CC-BY-4.0" + }, + "node_modules/chalk": { + "version": "4.1.2", + "resolved": "https://registry.npmjs.org/chalk/-/chalk-4.1.2.tgz", + "integrity": "sha512-oKnbhFyRIXpUuez8iBMmyEa4nbj4IOQyuhc/wy9kY7/WVPcwIO9VA668Pu8RkO7+0G76SLROeyw9CpQ061i4mA==", + "dev": true, + "license": "MIT", + "dependencies": { + "ansi-styles": "^4.1.0", + "supports-color": "^7.1.0" + }, + "engines": { + "node": ">=10" + }, + "funding": { + "url": "https://github.com/chalk/chalk?sponsor=1" + } + }, + "node_modules/char-regex": { + "version": "1.0.2", + "resolved": "https://registry.npmjs.org/char-regex/-/char-regex-1.0.2.tgz", + "integrity": "sha512-kWWXztvZ5SBQV+eRgKFeh8q5sLuZY2+8WUIzlxWVTg+oGwY14qylx1KbKzHd8P6ZYkAg0xyIDU9JMHhyJMZ1jw==", + "dev": true, + "license": "MIT", + "engines": { + "node": ">=10" + } + }, + "node_modules/chokidar": { + "version": "3.6.0", + "resolved": "https://registry.npmjs.org/chokidar/-/chokidar-3.6.0.tgz", + "integrity": "sha512-7VT13fmjotKpGipCW9JEQAusEPE+Ei8nl6/g4FBAmIm0GOOLMua9NDDo/DWp0ZAxCr3cPq5ZpBqmPAQgDda2Pw==", + "dev": true, + "license": "MIT", + "dependencies": { + "anymatch": "~3.1.2", + "braces": "~3.0.2", + "glob-parent": "~5.1.2", + "is-binary-path": "~2.1.0", + "is-glob": "~4.0.1", + "normalize-path": "~3.0.0", + "readdirp": "~3.6.0" + }, + "engines": { + "node": ">= 8.10.0" + }, + "funding": { + "url": "https://paulmillr.com/funding/" + }, + "optionalDependencies": { + "fsevents": "~2.3.2" + } + }, + "node_modules/ci-info": { + "version": "3.9.0", + "resolved": "https://registry.npmjs.org/ci-info/-/ci-info-3.9.0.tgz", + "integrity": "sha512-NIxF55hv4nSqQswkAeiOi1r83xy8JldOFDTWiug55KBu9Jnblncd2U6ViHmYgHf01TPZS77NJBhBMKdWj9HQMQ==", + "dev": true, + "funding": [ + { + "type": "github", + "url": "https://github.com/sponsors/sibiraj-s" + } + ], + "license": "MIT", + "engines": { + "node": ">=8" + } + }, + "node_modules/cjs-module-lexer": { + "version": "1.4.3", + "resolved": "https://registry.npmjs.org/cjs-module-lexer/-/cjs-module-lexer-1.4.3.tgz", + "integrity": "sha512-9z8TZaGM1pfswYeXrUpzPrkx8UnWYdhJclsiYMm6x/w5+nN+8Tf/LnAgfLGQCm59qAOxU8WwHEq2vNwF6i4j+Q==", + "dev": true, + "license": "MIT" + }, + "node_modules/cli-cursor": { + "version": "3.1.0", + "resolved": "https://registry.npmjs.org/cli-cursor/-/cli-cursor-3.1.0.tgz", + "integrity": "sha512-I/zHAwsKf9FqGoXM4WWRACob9+SNukZTd94DWF57E4toouRulbCxcUh6RKUEOQlYTHJnzkPMySvPNaaSLNfLZw==", + "dev": true, + "license": "MIT", + "dependencies": { + "restore-cursor": "^3.1.0" + }, + "engines": { + "node": ">=8" + } + }, + "node_modules/cli-spinners": { + "version": "2.9.2", + "resolved": "https://registry.npmjs.org/cli-spinners/-/cli-spinners-2.9.2.tgz", + "integrity": "sha512-ywqV+5MmyL4E7ybXgKys4DugZbX0FC6LnwrhjuykIjnK9k8OQacQ7axGKnjDXWNhns0xot3bZI5h55H8yo9cJg==", + "dev": true, + "license": "MIT", + "engines": { + "node": ">=6" + }, + "funding": { + "url": "https://github.com/sponsors/sindresorhus" + } + }, + "node_modules/cliui": { + "version": "8.0.1", + "resolved": "https://registry.npmjs.org/cliui/-/cliui-8.0.1.tgz", + "integrity": "sha512-BSeNnyus75C4//NQ9gQt1/csTXyo/8Sb+afLAkzAptFuMsod9HFokGNudZpi/oQV73hnVK+sR+5PVRMd+Dr7YQ==", + "dev": true, + "license": "ISC", + "dependencies": { + "string-width": "^4.2.0", + "strip-ansi": "^6.0.1", + "wrap-ansi": "^7.0.0" + }, + "engines": { + "node": ">=12" + } + }, + "node_modules/clone": { + "version": "1.0.4", + "resolved": "https://registry.npmjs.org/clone/-/clone-1.0.4.tgz", + "integrity": "sha512-JQHZ2QMW6l3aH/j6xCqQThY/9OH4D/9ls34cgkUBiEeocRTU04tHfKPBsUK1PqZCUQM7GiA0IIXJSuXHI64Kbg==", + "dev": true, + "license": "MIT", + "engines": { + "node": ">=0.8" + } + }, + "node_modules/clone-response": { + "version": "1.0.3", + "resolved": "https://registry.npmjs.org/clone-response/-/clone-response-1.0.3.tgz", + "integrity": "sha512-ROoL94jJH2dUVML2Y/5PEDNaSHgeOdSDicUyS7izcF63G6sTc/FTjLub4b8Il9S8S0beOfYt0TaA5qvFK+w0wA==", + "dev": true, + "license": "MIT", + "dependencies": { + "mimic-response": "^1.0.0" + }, + "funding": { + "url": "https://github.com/sponsors/sindresorhus" + } + }, + "node_modules/co": { + "version": "4.6.0", + "resolved": "https://registry.npmjs.org/co/-/co-4.6.0.tgz", + "integrity": "sha512-QVb0dM5HvG+uaxitm8wONl7jltx8dqhfU33DcqtOZcLSVIKSDDLDi7+0LbAKiyI8hD9u42m2YxXSkMGWThaecQ==", + "dev": true, + "license": "MIT", + "engines": { + "iojs": ">= 1.0.0", + "node": ">= 0.12.0" + } + }, + "node_modules/collect-v8-coverage": { + "version": "1.0.2", + "resolved": "https://registry.npmjs.org/collect-v8-coverage/-/collect-v8-coverage-1.0.2.tgz", + "integrity": "sha512-lHl4d5/ONEbLlJvaJNtsF/Lz+WvB07u2ycqTYbdrq7UypDXailES4valYb2eWiJFxZlVmpGekfqoxQhzyFdT4Q==", + "dev": true, + "license": "MIT" + }, + "node_modules/color-convert": { + "version": "2.0.1", + "resolved": "https://registry.npmjs.org/color-convert/-/color-convert-2.0.1.tgz", + "integrity": "sha512-RRECPsj7iu/xb5oKYcsFHSppFNnsj/52OVTRKb4zP5onXwVF3zVmmToNcOfGC+CRDpfK/U584fMg38ZHCaElKQ==", + "dev": true, + "license": "MIT", + "dependencies": { + "color-name": "~1.1.4" + }, + "engines": { + "node": ">=7.0.0" + } + }, + "node_modules/color-name": { + "version": "1.1.4", + "resolved": "https://registry.npmjs.org/color-name/-/color-name-1.1.4.tgz", + "integrity": "sha512-dOy+3AuW3a2wNbZHIuMZpTcgjGuLU/uBL/ubcZF9OXbDo8ff4O8yVp5Bf0efS8uEoYo5q4Fx7dY9OgQGXgAsQA==", + "dev": true, + "license": "MIT" + }, + "node_modules/combined-stream": { + "version": "1.0.8", + "resolved": "https://registry.npmjs.org/combined-stream/-/combined-stream-1.0.8.tgz", + "integrity": "sha512-FQN4MRfuJeHf7cBbBMJFXhKSDq+2kAArBlmRBvcvFE5BB1HZKXtSFASDhdlz9zOYwxh8lDdnvmMOe/+5cdoEdg==", + "license": "MIT", + "dependencies": { + "delayed-stream": "~1.0.0" + }, + "engines": { + "node": ">= 0.8" + } + }, + "node_modules/commander": { + "version": "9.5.0", + "resolved": "https://registry.npmjs.org/commander/-/commander-9.5.0.tgz", + "integrity": "sha512-KRs7WVDKg86PWiuAqhDrAQnTXZKraVcCc6vFdL14qrZ/DcWwuRo7VoiYXalXO7S5GKpqYiVEwCbgFDfxNHKJBQ==", + "dev": true, + "license": "MIT", + "engines": { + "node": "^12.20.0 || >=14" + } + }, + "node_modules/concat-map": { + "version": "0.0.1", + "resolved": "https://registry.npmjs.org/concat-map/-/concat-map-0.0.1.tgz", + "integrity": "sha512-/Srv4dswyQNBfohGpz9o6Yb3Gz3SrUDqBH5rTuhGR7ahtlbYKnVxw2bCFMRljaA7EXHaXZ8wsHdodFvbkhKmqg==", + "dev": true, + "license": "MIT" + }, + "node_modules/convert-source-map": { + "version": "2.0.0", + "resolved": "https://registry.npmjs.org/convert-source-map/-/convert-source-map-2.0.0.tgz", + "integrity": "sha512-Kvp459HrV2FEJ1CAsi1Ku+MY3kasH19TFykTz2xWmMeq6bk2NU3XXvfJ+Q61m0xktWwt+1HSYf3JZsTms3aRJg==", + "dev": true, + "license": "MIT" + }, + "node_modules/core-util-is": { + "version": "1.0.3", + "resolved": "https://registry.npmjs.org/core-util-is/-/core-util-is-1.0.3.tgz", + "integrity": "sha512-ZQBvi1DcpJ4GDqanjucZ2Hj3wEO5pZDS89BWbkcrvdxksJorwUDDZamX9ldFkp9aw2lmBDLgkObEA4DWNJ9FYQ==", + "license": "MIT" + }, + "node_modules/create-jest": { + "version": "29.7.0", + "resolved": "https://registry.npmjs.org/create-jest/-/create-jest-29.7.0.tgz", + "integrity": "sha512-Adz2bdH0Vq3F53KEMJOoftQFutWCukm6J24wbPWRO4k1kMY7gS7ds/uoJkNuV8wDCtWWnuwGcJwpWcih+zEW1Q==", + "dev": true, + "license": "MIT", + "dependencies": { + "@jest/types": "^29.6.3", + "chalk": "^4.0.0", + "exit": "^0.1.2", + "graceful-fs": "^4.2.9", + "jest-config": "^29.7.0", + "jest-util": "^29.7.0", + "prompts": "^2.0.1" + }, + "bin": { + "create-jest": "bin/create-jest.js" + }, + "engines": { + "node": "^14.15.0 || ^16.10.0 || >=18.0.0" + } + }, + "node_modules/cross-spawn": { + "version": "7.0.6", + "resolved": "https://registry.npmjs.org/cross-spawn/-/cross-spawn-7.0.6.tgz", + "integrity": "sha512-uV2QOWP2nWzsy2aMp8aRibhi9dlzF5Hgh5SHaB9OiTGEyDTiJJyx0uy51QXdyWbtAHNua4XJzUKca3OzKUd3vA==", + "dev": true, + "license": "MIT", + "dependencies": { + "path-key": "^3.1.0", + "shebang-command": "^2.0.0", + "which": "^2.0.1" + }, + "engines": { + "node": ">= 8" + } + }, + "node_modules/cross-spawn/node_modules/isexe": { + "version": "2.0.0", + "resolved": "https://registry.npmjs.org/isexe/-/isexe-2.0.0.tgz", + "integrity": "sha512-RHxMLp9lnKHGHRng9QFhRCMbYAcVpn69smSGcq3f36xjgVVWThj4qqLbTLlq7Ssj8B+fIQ1EuCEGI2lKsyQeIw==", + "dev": true, + "license": "ISC" + }, + "node_modules/cross-spawn/node_modules/which": { + "version": "2.0.2", + "resolved": "https://registry.npmjs.org/which/-/which-2.0.2.tgz", + "integrity": "sha512-BLI3Tl1TW3Pvl70l3yq3Y64i+awpwXqsGBYWkkqMtnbXgrMD+yj7rhW0kuEDxzJaYXGjEW5ogapKNMEKNMjibA==", + "dev": true, + "license": "ISC", + "dependencies": { + "isexe": "^2.0.0" + }, + "bin": { + "node-which": "bin/node-which" + }, + "engines": { + "node": ">= 8" + } + }, + "node_modules/data-view-buffer": { + "version": "1.0.2", + "resolved": "https://registry.npmjs.org/data-view-buffer/-/data-view-buffer-1.0.2.tgz", + "integrity": "sha512-EmKO5V3OLXh1rtK2wgXRansaK1/mtVdTUEiEI0W8RkvgT05kfxaH29PliLnpLP73yYO6142Q72QNa8Wx/A5CqQ==", + "dev": true, + "license": "MIT", + "dependencies": { + "call-bound": "^1.0.3", + "es-errors": "^1.3.0", + "is-data-view": "^1.0.2" + }, + "engines": { + "node": ">= 0.4" + }, + "funding": { + "url": "https://github.com/sponsors/ljharb" + } + }, + "node_modules/data-view-byte-length": { + "version": "1.0.2", + "resolved": "https://registry.npmjs.org/data-view-byte-length/-/data-view-byte-length-1.0.2.tgz", + "integrity": "sha512-tuhGbE6CfTM9+5ANGf+oQb72Ky/0+s3xKUpHvShfiz2RxMFgFPjsXuRLBVMtvMs15awe45SRb83D6wH4ew6wlQ==", + "dev": true, + "license": "MIT", + "dependencies": { + "call-bound": "^1.0.3", + "es-errors": "^1.3.0", + "is-data-view": "^1.0.2" + }, + "engines": { + "node": ">= 0.4" + }, + "funding": { + "url": "https://github.com/sponsors/inspect-js" + } + }, + "node_modules/data-view-byte-offset": { + "version": "1.0.1", + "resolved": "https://registry.npmjs.org/data-view-byte-offset/-/data-view-byte-offset-1.0.1.tgz", + "integrity": "sha512-BS8PfmtDGnrgYdOonGZQdLZslWIeCGFP9tpan0hi1Co2Zr2NKADsvGYA8XxuG/4UWgJ6Cjtv+YJnB6MM69QGlQ==", + "dev": true, + "license": "MIT", + "dependencies": { + "call-bound": "^1.0.2", + "es-errors": "^1.3.0", + "is-data-view": "^1.0.1" + }, + "engines": { + "node": ">= 0.4" + }, + "funding": { + "url": "https://github.com/sponsors/ljharb" + } + }, + "node_modules/debug": { + "version": "4.4.0", + "resolved": "https://registry.npmjs.org/debug/-/debug-4.4.0.tgz", + "integrity": "sha512-6WTZ/IxCY/T6BALoZHaE4ctp9xm+Z5kY/pzYaCHRFeyVhojxlrm+46y68HA6hr0TcwEssoxNiDEUJQjfPZ/RYA==", + "dev": true, + "license": "MIT", + "dependencies": { + "ms": "^2.1.3" + }, + "engines": { + "node": ">=6.0" + }, + "peerDependenciesMeta": { + "supports-color": { + "optional": true + } + } + }, + "node_modules/decompress-response": { + "version": "6.0.0", + "resolved": "https://registry.npmjs.org/decompress-response/-/decompress-response-6.0.0.tgz", + "integrity": "sha512-aW35yZM6Bb/4oJlZncMH2LCoZtJXTRxES17vE3hoRiowU2kWHaJKFkSBDnDR+cm9J+9QhXmREyIfv0pji9ejCQ==", + "dev": true, + "license": "MIT", + "dependencies": { + "mimic-response": "^3.1.0" + }, + "engines": { + "node": ">=10" + }, + "funding": { + "url": "https://github.com/sponsors/sindresorhus" + } + }, + "node_modules/decompress-response/node_modules/mimic-response": { + "version": "3.1.0", + "resolved": "https://registry.npmjs.org/mimic-response/-/mimic-response-3.1.0.tgz", + "integrity": "sha512-z0yWI+4FDrrweS8Zmt4Ej5HdJmky15+L2e6Wgn3+iK5fWzb6T3fhNFq2+MeTRb064c6Wr4N/wv0DzQTjNzHNGQ==", + "dev": true, + "license": "MIT", + "engines": { + "node": ">=10" + }, + "funding": { + "url": "https://github.com/sponsors/sindresorhus" + } + }, + "node_modules/dedent": { + "version": "1.5.3", + "resolved": "https://registry.npmjs.org/dedent/-/dedent-1.5.3.tgz", + "integrity": "sha512-NHQtfOOW68WD8lgypbLA5oT+Bt0xXJhiYvoR6SmmNXZfpzOGXwdKWmcwG8N7PwVVWV3eF/68nmD9BaJSsTBhyQ==", + "dev": true, + "license": "MIT", + "peerDependencies": { + "babel-plugin-macros": "^3.1.0" + }, + "peerDependenciesMeta": { + "babel-plugin-macros": { + "optional": true + } + } + }, + "node_modules/deep-is": { + "version": "0.1.4", + "resolved": "https://registry.npmjs.org/deep-is/-/deep-is-0.1.4.tgz", + "integrity": "sha512-oIPzksmTg4/MriiaYGO+okXDT7ztn/w3Eptv/+gSIdMdKsJo0u4CfYNFJPy+4SKMuCqGw2wxnA+URMg3t8a/bQ==", + "dev": true, + "license": "MIT" + }, + "node_modules/deepmerge": { + "version": "4.3.1", + "resolved": "https://registry.npmjs.org/deepmerge/-/deepmerge-4.3.1.tgz", + "integrity": "sha512-3sUqbMEc77XqpdNO7FRyRog+eW3ph+GYCbj+rK+uYyRMuwsVy0rMiVtPn+QJlKFvWP/1PYpapqYn0Me2knFn+A==", + "dev": true, + "license": "MIT", + "engines": { + "node": ">=0.10.0" + } + }, + "node_modules/defaults": { + "version": "1.0.4", + "resolved": "https://registry.npmjs.org/defaults/-/defaults-1.0.4.tgz", + "integrity": "sha512-eFuaLoy/Rxalv2kr+lqMlUnrDWV+3j4pljOIJgLIhI058IQfWJ7vXhyEIHu+HtC738klGALYxOKDO0bQP3tg8A==", + "dev": true, + "license": "MIT", + "dependencies": { + "clone": "^1.0.2" + }, + "funding": { + "url": "https://github.com/sponsors/sindresorhus" + } + }, + "node_modules/defer-to-connect": { + "version": "2.0.1", + "resolved": "https://registry.npmjs.org/defer-to-connect/-/defer-to-connect-2.0.1.tgz", + "integrity": "sha512-4tvttepXG1VaYGrRibk5EwJd1t4udunSOVMdLSAL6mId1ix438oPwPZMALY41FCijukO1L0twNcGsdzS7dHgDg==", + "dev": true, + "license": "MIT", + "engines": { + "node": ">=10" + } + }, + "node_modules/define-data-property": { + "version": "1.1.4", + "resolved": "https://registry.npmjs.org/define-data-property/-/define-data-property-1.1.4.tgz", + "integrity": "sha512-rBMvIzlpA8v6E+SJZoo++HAYqsLrkg7MSfIinMPFhmkorw7X+dOXVJQs+QT69zGkzMyfDnIMN2Wid1+NbL3T+A==", + "dev": true, + "license": "MIT", + "dependencies": { + "es-define-property": "^1.0.0", + "es-errors": "^1.3.0", + "gopd": "^1.0.1" + }, + "engines": { + "node": ">= 0.4" + }, + "funding": { + "url": "https://github.com/sponsors/ljharb" + } + }, + "node_modules/define-properties": { + "version": "1.2.1", + "resolved": "https://registry.npmjs.org/define-properties/-/define-properties-1.2.1.tgz", + "integrity": "sha512-8QmQKqEASLd5nx0U1B1okLElbUuuttJ/AnYmRXbbbGDWh6uS208EjD4Xqq/I9wK7u0v6O08XhTWnt5XtEbR6Dg==", + "dev": true, + "license": "MIT", + "dependencies": { + "define-data-property": "^1.0.1", + "has-property-descriptors": "^1.0.0", + "object-keys": "^1.1.1" + }, + "engines": { + "node": ">= 0.4" + }, + "funding": { + "url": "https://github.com/sponsors/ljharb" + } + }, + "node_modules/delayed-stream": { + "version": "1.0.0", + "resolved": "https://registry.npmjs.org/delayed-stream/-/delayed-stream-1.0.0.tgz", + "integrity": "sha512-ZySD7Nf91aLB0RxL4KGrKHBXl7Eds1DAmEdcoVawXnLD7SDhpNgtuII2aAkg7a7QS41jxPSZ17p4VdGnMHk3MQ==", + "license": "MIT", + "engines": { + "node": ">=0.4.0" + } + }, + "node_modules/detect-newline": { + "version": "3.1.0", + "resolved": "https://registry.npmjs.org/detect-newline/-/detect-newline-3.1.0.tgz", + "integrity": "sha512-TLz+x/vEXm/Y7P7wn1EJFNLxYpUD4TgMosxY6fAVJUnJMbupHBOncxyWUG9OpTaH9EBD7uFI5LfEgmMOc54DsA==", + "dev": true, + "license": "MIT", + "engines": { + "node": ">=8" + } + }, + "node_modules/diff-sequences": { + "version": "29.6.3", + "resolved": "https://registry.npmjs.org/diff-sequences/-/diff-sequences-29.6.3.tgz", + "integrity": "sha512-EjePK1srD3P08o2j4f0ExnylqRs5B9tJjcp9t1krH2qRi8CCdsYfwe9JgSLurFBWwq4uOlipzfk5fHNvwFKr8Q==", + "dev": true, + "license": "MIT", + "engines": { + "node": "^14.15.0 || ^16.10.0 || >=18.0.0" + } + }, + "node_modules/dunder-proto": { + "version": "1.0.1", + "resolved": "https://registry.npmjs.org/dunder-proto/-/dunder-proto-1.0.1.tgz", + "integrity": "sha512-KIN/nDJBQRcXw0MLVhZE9iQHmG68qAVIBg9CqmUYjmQIhgij9U5MFvrqkUL5FbtyyzZuOeOt0zdeRe4UY7ct+A==", + "license": "MIT", + "dependencies": { + "call-bind-apply-helpers": "^1.0.1", + "es-errors": "^1.3.0", + "gopd": "^1.2.0" + }, + "engines": { + "node": ">= 0.4" + } + }, + "node_modules/electron-to-chromium": { + "version": "1.5.124", + "resolved": "https://registry.npmjs.org/electron-to-chromium/-/electron-to-chromium-1.5.124.tgz", + "integrity": "sha512-riELkpDUqBi00gqreV3RIGoowxGrfueEKBd6zPdOk/I8lvuFpBGNkYoHof3zUHbiTBsIU8oxdIIL/WNrAG1/7A==", + "dev": true, + "license": "ISC" + }, + "node_modules/elm": { + "version": "0.19.1-6", + "resolved": "https://registry.npmjs.org/elm/-/elm-0.19.1-6.tgz", + "integrity": "sha512-mKYyierHICPdMx/vhiIacdPmTPnh889gjHOZ75ZAoCxo3lZmSWbGP8HMw78wyctJH0HwvTmeKhlYSWboQNYPeQ==", + "dev": true, + "hasInstallScript": true, + "license": "BSD-3-Clause", + "bin": { + "elm": "bin/elm" + }, + "engines": { + "node": ">=7.0.0" + }, + "optionalDependencies": { + "@elm_binaries/darwin_arm64": "0.19.1-0", + "@elm_binaries/darwin_x64": "0.19.1-0", + "@elm_binaries/linux_x64": "0.19.1-0", + "@elm_binaries/win32_x64": "0.19.1-0" + } + }, + "node_modules/elm-format": { + "version": "0.8.7", + "resolved": "https://registry.npmjs.org/elm-format/-/elm-format-0.8.7.tgz", + "integrity": "sha512-sVzFXfWnb+6rzXK+q3e3Ccgr6/uS5mFbFk1VSmigC+x2XZ28QycAa7lS8owl009ALPhRQk+pZ95Eq5ANjpEZsQ==", + "dev": true, + "hasInstallScript": true, + "license": "BSD-3-Clause", + "bin": { + "elm-format": "bin/elm-format" + }, + "optionalDependencies": { + "@avh4/elm-format-darwin-arm64": "0.8.7-2", + "@avh4/elm-format-darwin-x64": "0.8.7-2", + "@avh4/elm-format-linux-arm64": "0.8.7-2", + "@avh4/elm-format-linux-x64": "0.8.7-2", + "@avh4/elm-format-win32-x64": "0.8.7-2" + } + }, + "node_modules/elm-review": { + "version": "2.13.2", + "resolved": "https://registry.npmjs.org/elm-review/-/elm-review-2.13.2.tgz", + "integrity": "sha512-kI34BQ/EN1NC4KUcdZWAGNbaxWmR80kqJQRjT1ZmC0AyZRiJqdylhANucyzhPKEz60VGAkqau5axpySWXbdPLg==", + "dev": true, + "license": "BSD-3-Clause", + "dependencies": { + "chalk": "^4.0.0", + "chokidar": "^3.5.2", + "cross-spawn": "^7.0.3", + "elm-solve-deps-wasm": "^1.0.2 || ^2.0.0", + "fastest-levenshtein": "^1.0.16", + "find-up": "^4.1.0 || ^5.0.0", + "folder-hash": "^3.3.0", + "got": "^11.8.5", + "graceful-fs": "^4.2.11", + "minimist": "^1.2.6", + "ora": "^5.4.0", + "path-key": "^3.1.1", + "prompts": "^2.2.1", + "strip-ansi": "^6.0.0", + "terminal-link": "^2.1.1", + "tinyglobby": "^0.2.10", + "which": "^2.0.2", + "wrap-ansi": "^7.0.0" + }, + "bin": { + "elm-review": "bin/elm-review" + }, + "engines": { + "node": "14 >=14.21 || 16 >=16.20 || 18 || 20 || >=22" + }, + "funding": { + "url": "https://github.com/sponsors/jfmengels" + } + }, + "node_modules/elm-review/node_modules/isexe": { + "version": "2.0.0", + "resolved": "https://registry.npmjs.org/isexe/-/isexe-2.0.0.tgz", + "integrity": "sha512-RHxMLp9lnKHGHRng9QFhRCMbYAcVpn69smSGcq3f36xjgVVWThj4qqLbTLlq7Ssj8B+fIQ1EuCEGI2lKsyQeIw==", + "dev": true, + "license": "ISC" + }, + "node_modules/elm-review/node_modules/which": { + "version": "2.0.2", + "resolved": "https://registry.npmjs.org/which/-/which-2.0.2.tgz", + "integrity": "sha512-BLI3Tl1TW3Pvl70l3yq3Y64i+awpwXqsGBYWkkqMtnbXgrMD+yj7rhW0kuEDxzJaYXGjEW5ogapKNMEKNMjibA==", + "dev": true, + "license": "ISC", + "dependencies": { + "isexe": "^2.0.0" + }, + "bin": { + "node-which": "bin/node-which" + }, + "engines": { + "node": ">= 8" + } + }, + "node_modules/elm-solve-deps-wasm": { + "version": "2.0.0", + "resolved": "https://registry.npmjs.org/elm-solve-deps-wasm/-/elm-solve-deps-wasm-2.0.0.tgz", + "integrity": "sha512-11OV8FgB9qsth/F94q2SJjb1MoEgbworSyNM1L+YlxVoaxp7wtWPyA8cNcPEkSoIKG1B8Tqg68ED1P6dVamHSg==", + "dev": true, + "license": "MPL-2.0" + }, + "node_modules/elm-test": { + "version": "0.19.1-revision15", + "resolved": "https://registry.npmjs.org/elm-test/-/elm-test-0.19.1-revision15.tgz", + "integrity": "sha512-QusEZmlctM4VePiwemfxwcDrhDHfHXuXau3SedRwWuBBnPQK3/WjMUzULWSbTCYHIj3DgkA84Co+V/nE0161cg==", + "dev": true, + "license": "BSD-3-Clause", + "dependencies": { + "chalk": "^4.1.2", + "chokidar": "^3.5.3", + "commander": "^9.4.1", + "cross-spawn": "^7.0.6", + "elm-solve-deps-wasm": "^1.0.2 || ^2.0.0", + "graceful-fs": "^4.2.10", + "split": "^1.0.1", + "tinyglobby": "^0.2.10", + "which": "^2.0.2", + "xmlbuilder": "^15.1.1" + }, + "bin": { + "elm-test": "bin/elm-test" + }, + "engines": { + "node": ">=12.20.0" + } + }, + "node_modules/elm-test/node_modules/isexe": { + "version": "2.0.0", + "resolved": "https://registry.npmjs.org/isexe/-/isexe-2.0.0.tgz", + "integrity": "sha512-RHxMLp9lnKHGHRng9QFhRCMbYAcVpn69smSGcq3f36xjgVVWThj4qqLbTLlq7Ssj8B+fIQ1EuCEGI2lKsyQeIw==", + "dev": true, + "license": "ISC" + }, + "node_modules/elm-test/node_modules/which": { + "version": "2.0.2", + "resolved": "https://registry.npmjs.org/which/-/which-2.0.2.tgz", + "integrity": "sha512-BLI3Tl1TW3Pvl70l3yq3Y64i+awpwXqsGBYWkkqMtnbXgrMD+yj7rhW0kuEDxzJaYXGjEW5ogapKNMEKNMjibA==", + "dev": true, + "license": "ISC", + "dependencies": { + "isexe": "^2.0.0" + }, + "bin": { + "node-which": "bin/node-which" + }, + "engines": { + "node": ">= 8" + } + }, + "node_modules/emittery": { + "version": "0.13.1", + "resolved": "https://registry.npmjs.org/emittery/-/emittery-0.13.1.tgz", + "integrity": "sha512-DeWwawk6r5yR9jFgnDKYt4sLS0LmHJJi3ZOnb5/JdbYwj3nW+FxQnHIjhBKz8YLC7oRNPVM9NQ47I3CVx34eqQ==", + "dev": true, + "license": "MIT", + "engines": { + "node": ">=12" + }, + "funding": { + "url": "https://github.com/sindresorhus/emittery?sponsor=1" + } + }, + "node_modules/emoji-regex": { + "version": "8.0.0", + "resolved": "https://registry.npmjs.org/emoji-regex/-/emoji-regex-8.0.0.tgz", + "integrity": "sha512-MSjYzcWNOA0ewAHpz0MxpYFvwg6yjy1NG3xteoqz644VCo/RPgnr1/GGt+ic3iJTzQ8Eu3TdM14SawnVUmGE6A==", + "dev": true, + "license": "MIT" + }, + "node_modules/end-of-stream": { + "version": "1.4.4", + "resolved": "https://registry.npmjs.org/end-of-stream/-/end-of-stream-1.4.4.tgz", + "integrity": "sha512-+uw1inIHVPQoaVuHzRyXd21icM+cnt4CzD5rW+NC1wjOUSTOs+Te7FOv7AhN7vS9x/oIyhLP5PR1H+phQAHu5Q==", + "dev": true, + "license": "MIT", + "dependencies": { + "once": "^1.4.0" + } + }, + "node_modules/error-ex": { + "version": "1.3.2", + "resolved": "https://registry.npmjs.org/error-ex/-/error-ex-1.3.2.tgz", + "integrity": "sha512-7dFHNmqeFSEt2ZBsCriorKnn3Z2pj+fd9kmI6QoWw4//DL+icEBfc0U7qJCisqrTsKTjw4fNFy2pW9OqStD84g==", + "dev": true, + "license": "MIT", + "dependencies": { + "is-arrayish": "^0.2.1" + } + }, + "node_modules/es-abstract": { + "version": "1.23.9", + "resolved": "https://registry.npmjs.org/es-abstract/-/es-abstract-1.23.9.tgz", + "integrity": "sha512-py07lI0wjxAC/DcfK1S6G7iANonniZwTISvdPzk9hzeH0IZIshbuuFxLIU96OyF89Yb9hiqWn8M/bY83KY5vzA==", + "dev": true, + "license": "MIT", + "dependencies": { + "array-buffer-byte-length": "^1.0.2", + "arraybuffer.prototype.slice": "^1.0.4", + "available-typed-arrays": "^1.0.7", + "call-bind": "^1.0.8", + "call-bound": "^1.0.3", + "data-view-buffer": "^1.0.2", + "data-view-byte-length": "^1.0.2", + "data-view-byte-offset": "^1.0.1", + "es-define-property": "^1.0.1", + "es-errors": "^1.3.0", + "es-object-atoms": "^1.0.0", + "es-set-tostringtag": "^2.1.0", + "es-to-primitive": "^1.3.0", + "function.prototype.name": "^1.1.8", + "get-intrinsic": "^1.2.7", + "get-proto": "^1.0.0", + "get-symbol-description": "^1.1.0", + "globalthis": "^1.0.4", + "gopd": "^1.2.0", + "has-property-descriptors": "^1.0.2", + "has-proto": "^1.2.0", + "has-symbols": "^1.1.0", + "hasown": "^2.0.2", + "internal-slot": "^1.1.0", + "is-array-buffer": "^3.0.5", + "is-callable": "^1.2.7", + "is-data-view": "^1.0.2", + "is-regex": "^1.2.1", + "is-shared-array-buffer": "^1.0.4", + "is-string": "^1.1.1", + "is-typed-array": "^1.1.15", + "is-weakref": "^1.1.0", + "math-intrinsics": "^1.1.0", + "object-inspect": "^1.13.3", + "object-keys": "^1.1.1", + "object.assign": "^4.1.7", + "own-keys": "^1.0.1", + "regexp.prototype.flags": "^1.5.3", + "safe-array-concat": "^1.1.3", + "safe-push-apply": "^1.0.0", + "safe-regex-test": "^1.1.0", + "set-proto": "^1.0.0", + "string.prototype.trim": "^1.2.10", + "string.prototype.trimend": "^1.0.9", + "string.prototype.trimstart": "^1.0.8", + "typed-array-buffer": "^1.0.3", + "typed-array-byte-length": "^1.0.3", + "typed-array-byte-offset": "^1.0.4", + "typed-array-length": "^1.0.7", + "unbox-primitive": "^1.1.0", + "which-typed-array": "^1.1.18" + }, + "engines": { + "node": ">= 0.4" + }, + "funding": { + "url": "https://github.com/sponsors/ljharb" + } + }, + "node_modules/es-define-property": { + "version": "1.0.1", + "resolved": "https://registry.npmjs.org/es-define-property/-/es-define-property-1.0.1.tgz", + "integrity": "sha512-e3nRfgfUZ4rNGL232gUgX06QNyyez04KdjFrF+LTRoOXmrOgFKDg4BCdsjW8EnT69eqdYGmRpJwiPVYNrCaW3g==", + "license": "MIT", + "engines": { + "node": ">= 0.4" + } + }, + "node_modules/es-errors": { + "version": "1.3.0", + "resolved": "https://registry.npmjs.org/es-errors/-/es-errors-1.3.0.tgz", + "integrity": "sha512-Zf5H2Kxt2xjTvbJvP2ZWLEICxA6j+hAmMzIlypy4xcBg1vKVnx89Wy0GbS+kf5cwCVFFzdCFh2XSCFNULS6csw==", + "license": "MIT", + "engines": { + "node": ">= 0.4" + } + }, + "node_modules/es-object-atoms": { + "version": "1.1.1", + "resolved": "https://registry.npmjs.org/es-object-atoms/-/es-object-atoms-1.1.1.tgz", + "integrity": "sha512-FGgH2h8zKNim9ljj7dankFPcICIK9Cp5bm+c2gQSYePhpaG5+esrLODihIorn+Pe6FGJzWhXQotPv73jTaldXA==", + "license": "MIT", + "dependencies": { + "es-errors": "^1.3.0" + }, + "engines": { + "node": ">= 0.4" + } + }, + "node_modules/es-set-tostringtag": { + "version": "2.1.0", + "resolved": "https://registry.npmjs.org/es-set-tostringtag/-/es-set-tostringtag-2.1.0.tgz", + "integrity": "sha512-j6vWzfrGVfyXxge+O0x5sh6cvxAog0a/4Rdd2K36zCMV5eJ+/+tOAngRO8cODMNWbVRdVlmGZQL2YS3yR8bIUA==", + "license": "MIT", + "dependencies": { + "es-errors": "^1.3.0", + "get-intrinsic": "^1.2.6", + "has-tostringtag": "^1.0.2", + "hasown": "^2.0.2" + }, + "engines": { + "node": ">= 0.4" + } + }, + "node_modules/es-to-primitive": { + "version": "1.3.0", + "resolved": "https://registry.npmjs.org/es-to-primitive/-/es-to-primitive-1.3.0.tgz", + "integrity": "sha512-w+5mJ3GuFL+NjVtJlvydShqE1eN3h3PbI7/5LAsYJP/2qtuMXjfL2LpHSRqo4b4eSF5K/DH1JXKUAHSB2UW50g==", + "dev": true, + "license": "MIT", + "dependencies": { + "is-callable": "^1.2.7", + "is-date-object": "^1.0.5", + "is-symbol": "^1.0.4" + }, + "engines": { + "node": ">= 0.4" + }, + "funding": { + "url": "https://github.com/sponsors/ljharb" + } + }, + "node_modules/escalade": { + "version": "3.2.0", + "resolved": "https://registry.npmjs.org/escalade/-/escalade-3.2.0.tgz", + "integrity": "sha512-WUj2qlxaQtO4g6Pq5c29GTcWGDyd8itL8zTlipgECz3JesAiiOKotd8JU6otB3PACgG6xkJUyVhboMS+bje/jA==", + "dev": true, + "license": "MIT", + "engines": { + "node": ">=6" + } + }, + "node_modules/escape-string-regexp": { + "version": "2.0.0", + "resolved": "https://registry.npmjs.org/escape-string-regexp/-/escape-string-regexp-2.0.0.tgz", + "integrity": "sha512-UpzcLCXolUWcNu5HtVMHYdXJjArjsF9C0aNnquZYY4uW/Vu0miy5YoWvbV345HauVvcAUnpRuhMMcqTcGOY2+w==", + "dev": true, + "license": "MIT", + "engines": { + "node": ">=8" + } + }, + "node_modules/eslint": { + "version": "9.33.0", + "resolved": "https://registry.npmjs.org/eslint/-/eslint-9.33.0.tgz", + "integrity": "sha512-TS9bTNIryDzStCpJN93aC5VRSW3uTx9sClUn4B87pwiCaJh220otoI0X8mJKr+VcPtniMdN8GKjlwgWGUv5ZKA==", + "dev": true, + "license": "MIT", + "dependencies": { + "@eslint-community/eslint-utils": "^4.2.0", + "@eslint-community/regexpp": "^4.12.1", + "@eslint/config-array": "^0.21.0", + "@eslint/config-helpers": "^0.3.1", + "@eslint/core": "^0.15.2", + "@eslint/eslintrc": "^3.3.1", + "@eslint/js": "9.33.0", + "@eslint/plugin-kit": "^0.3.5", + "@humanfs/node": "^0.16.6", + "@humanwhocodes/module-importer": "^1.0.1", + "@humanwhocodes/retry": "^0.4.2", + "@types/estree": "^1.0.6", + "@types/json-schema": "^7.0.15", + "ajv": "^6.12.4", + "chalk": "^4.0.0", + "cross-spawn": "^7.0.6", + "debug": "^4.3.2", + "escape-string-regexp": "^4.0.0", + "eslint-scope": "^8.4.0", + "eslint-visitor-keys": "^4.2.1", + "espree": "^10.4.0", + "esquery": "^1.5.0", + "esutils": "^2.0.2", + "fast-deep-equal": "^3.1.3", + "file-entry-cache": "^8.0.0", + "find-up": "^5.0.0", + "glob-parent": "^6.0.2", + "ignore": "^5.2.0", + "imurmurhash": "^0.1.4", + "is-glob": "^4.0.0", + "json-stable-stringify-without-jsonify": "^1.0.1", + "lodash.merge": "^4.6.2", + "minimatch": "^3.1.2", + "natural-compare": "^1.4.0", + "optionator": "^0.9.3" + }, + "bin": { + "eslint": "bin/eslint.js" + }, + "engines": { + "node": "^18.18.0 || ^20.9.0 || >=21.1.0" + }, + "funding": { + "url": "https://eslint.org/donate" + }, + "peerDependencies": { + "jiti": "*" + }, + "peerDependenciesMeta": { + "jiti": { + "optional": true + } + } + }, + "node_modules/eslint-plugin-jest": { + "version": "28.11.0", + "resolved": "https://registry.npmjs.org/eslint-plugin-jest/-/eslint-plugin-jest-28.11.0.tgz", + "integrity": "sha512-QAfipLcNCWLVocVbZW8GimKn5p5iiMcgGbRzz8z/P5q7xw+cNEpYqyzFMtIF/ZgF2HLOyy+dYBut+DoYolvqig==", + "dev": true, + "license": "MIT", + "dependencies": { + "@typescript-eslint/utils": "^6.0.0 || ^7.0.0 || ^8.0.0" + }, + "engines": { + "node": "^16.10.0 || ^18.12.0 || >=20.0.0" + }, + "peerDependencies": { + "@typescript-eslint/eslint-plugin": "^6.0.0 || ^7.0.0 || ^8.0.0", + "eslint": "^7.0.0 || ^8.0.0 || ^9.0.0", + "jest": "*" + }, + "peerDependenciesMeta": { + "@typescript-eslint/eslint-plugin": { + "optional": true + }, + "jest": { + "optional": true + } + } + }, + "node_modules/eslint-scope": { + "version": "8.4.0", + "resolved": "https://registry.npmjs.org/eslint-scope/-/eslint-scope-8.4.0.tgz", + "integrity": "sha512-sNXOfKCn74rt8RICKMvJS7XKV/Xk9kA7DyJr8mJik3S7Cwgy3qlkkmyS2uQB3jiJg6VNdZd/pDBJu0nvG2NlTg==", + "dev": true, + "license": "BSD-2-Clause", + "dependencies": { + "esrecurse": "^4.3.0", + "estraverse": "^5.2.0" + }, + "engines": { + "node": "^18.18.0 || ^20.9.0 || >=21.1.0" + }, + "funding": { + "url": "https://opencollective.com/eslint" + } + }, + "node_modules/eslint-visitor-keys": { + "version": "4.2.1", + "resolved": "https://registry.npmjs.org/eslint-visitor-keys/-/eslint-visitor-keys-4.2.1.tgz", + "integrity": "sha512-Uhdk5sfqcee/9H/rCOJikYz67o0a2Tw2hGRPOG2Y1R2dg7brRe1uG0yaNQDHu+TO/uQPF/5eCapvYSmHUjt7JQ==", + "dev": true, + "license": "Apache-2.0", + "engines": { + "node": "^18.18.0 || ^20.9.0 || >=21.1.0" + }, + "funding": { + "url": "https://opencollective.com/eslint" + } + }, + "node_modules/eslint/node_modules/escape-string-regexp": { + "version": "4.0.0", + "resolved": "https://registry.npmjs.org/escape-string-regexp/-/escape-string-regexp-4.0.0.tgz", + "integrity": "sha512-TtpcNJ3XAzx3Gq8sWRzJaVajRs0uVxA2YAkdb1jm2YkPz4G6egUFAyA3n5vtEIZefPk5Wa4UXbKuS5fKkJWdgA==", + "dev": true, + "license": "MIT", + "engines": { + "node": ">=10" + }, + "funding": { + "url": "https://github.com/sponsors/sindresorhus" + } + }, + "node_modules/eslint/node_modules/glob-parent": { + "version": "6.0.2", + "resolved": "https://registry.npmjs.org/glob-parent/-/glob-parent-6.0.2.tgz", + "integrity": "sha512-XxwI8EOhVQgWp6iDL+3b0r86f4d6AX6zSU55HfB4ydCEuXLXc5FcYeOu+nnGftS4TEju/11rt4KJPTMgbfmv4A==", + "dev": true, + "license": "ISC", + "dependencies": { + "is-glob": "^4.0.3" + }, + "engines": { + "node": ">=10.13.0" + } + }, + "node_modules/eslint/node_modules/minimatch": { + "version": "3.1.2", + "resolved": "https://registry.npmjs.org/minimatch/-/minimatch-3.1.2.tgz", + "integrity": "sha512-J7p63hRiAjw1NDEww1W7i37+ByIrOWO5XQQAzZ3VOcL0PNybwpfmV/N05zFAzwQ9USyEcX6t3UO+K5aqBQOIHw==", + "dev": true, + "license": "ISC", + "dependencies": { + "brace-expansion": "^1.1.7" + }, + "engines": { + "node": "*" + } + }, + "node_modules/espree": { + "version": "10.4.0", + "resolved": "https://registry.npmjs.org/espree/-/espree-10.4.0.tgz", + "integrity": "sha512-j6PAQ2uUr79PZhBjP5C5fhl8e39FmRnOjsD5lGnWrFU8i2G776tBK7+nP8KuQUTTyAZUwfQqXAgrVH5MbH9CYQ==", + "dev": true, + "license": "BSD-2-Clause", + "dependencies": { + "acorn": "^8.15.0", + "acorn-jsx": "^5.3.2", + "eslint-visitor-keys": "^4.2.1" + }, + "engines": { + "node": "^18.18.0 || ^20.9.0 || >=21.1.0" + }, + "funding": { + "url": "https://opencollective.com/eslint" + } + }, + "node_modules/esprima": { + "version": "4.0.1", + "resolved": "https://registry.npmjs.org/esprima/-/esprima-4.0.1.tgz", + "integrity": "sha512-eGuFFw7Upda+g4p+QHvnW0RyTX/SVeJBDM/gCtMARO0cLuT2HcEKnTPvhjV6aGeqrCB/sbNop0Kszm0jsaWU4A==", + "dev": true, + "license": "BSD-2-Clause", + "bin": { + "esparse": "bin/esparse.js", + "esvalidate": "bin/esvalidate.js" + }, + "engines": { + "node": ">=4" + } + }, + "node_modules/esquery": { + "version": "1.6.0", + "resolved": "https://registry.npmjs.org/esquery/-/esquery-1.6.0.tgz", + "integrity": "sha512-ca9pw9fomFcKPvFLXhBKUK90ZvGibiGOvRJNbjljY7s7uq/5YO4BOzcYtJqExdx99rF6aAcnRxHmcUHcz6sQsg==", + "dev": true, + "license": "BSD-3-Clause", + "dependencies": { + "estraverse": "^5.1.0" + }, + "engines": { + "node": ">=0.10" + } + }, + "node_modules/esrecurse": { + "version": "4.3.0", + "resolved": "https://registry.npmjs.org/esrecurse/-/esrecurse-4.3.0.tgz", + "integrity": "sha512-KmfKL3b6G+RXvP8N1vr3Tq1kL/oCFgn2NYXEtqP8/L3pKapUA4G8cFVaoF3SU323CD4XypR/ffioHmkti6/Tag==", + "dev": true, + "license": "BSD-2-Clause", + "dependencies": { + "estraverse": "^5.2.0" + }, + "engines": { + "node": ">=4.0" + } + }, + "node_modules/estraverse": { + "version": "5.3.0", + "resolved": "https://registry.npmjs.org/estraverse/-/estraverse-5.3.0.tgz", + "integrity": "sha512-MMdARuVEQziNTeJD8DgMqmhwR11BRQ/cBP+pLtYdSTnf3MIO8fFeiINEbX36ZdNlfU/7A9f3gUw49B3oQsvwBA==", + "dev": true, + "license": "BSD-2-Clause", + "engines": { + "node": ">=4.0" + } + }, + "node_modules/esutils": { + "version": "2.0.3", + "resolved": "https://registry.npmjs.org/esutils/-/esutils-2.0.3.tgz", + "integrity": "sha512-kVscqXk4OCp68SZ0dkgEKVi6/8ij300KBWTJq32P/dYeWTSwK41WyTxalN1eRmA5Z9UU/LX9D7FWSmV9SAYx6g==", + "dev": true, + "license": "BSD-2-Clause", + "engines": { + "node": ">=0.10.0" + } + }, + "node_modules/execa": { + "version": "5.1.1", + "resolved": "https://registry.npmjs.org/execa/-/execa-5.1.1.tgz", + "integrity": "sha512-8uSpZZocAZRBAPIEINJj3Lo9HyGitllczc27Eh5YYojjMFMn8yHMDMaUHE2Jqfq05D/wucwI4JGURyXt1vchyg==", + "dev": true, + "license": "MIT", + "dependencies": { + "cross-spawn": "^7.0.3", + "get-stream": "^6.0.0", + "human-signals": "^2.1.0", + "is-stream": "^2.0.0", + "merge-stream": "^2.0.0", + "npm-run-path": "^4.0.1", + "onetime": "^5.1.2", + "signal-exit": "^3.0.3", + "strip-final-newline": "^2.0.0" + }, + "engines": { + "node": ">=10" + }, + "funding": { + "url": "https://github.com/sindresorhus/execa?sponsor=1" + } + }, + "node_modules/execa/node_modules/get-stream": { + "version": "6.0.1", + "resolved": "https://registry.npmjs.org/get-stream/-/get-stream-6.0.1.tgz", + "integrity": "sha512-ts6Wi+2j3jQjqi70w5AlN8DFnkSwC+MqmxEzdEALB2qXZYV3X/b1CTfgPLGJNMeAWxdPfU8FO1ms3NUfaHCPYg==", + "dev": true, + "license": "MIT", + "engines": { + "node": ">=10" + }, + "funding": { + "url": "https://github.com/sponsors/sindresorhus" + } + }, + "node_modules/exit": { + "version": "0.1.2", + "resolved": "https://registry.npmjs.org/exit/-/exit-0.1.2.tgz", + "integrity": "sha512-Zk/eNKV2zbjpKzrsQ+n1G6poVbErQxJ0LBOJXaKZ1EViLzH+hrLu9cdXI4zw9dBQJslwBEpbQ2P1oS7nDxs6jQ==", + "dev": true, + "engines": { + "node": ">= 0.8.0" + } + }, + "node_modules/expect": { + "version": "29.7.0", + "resolved": "https://registry.npmjs.org/expect/-/expect-29.7.0.tgz", + "integrity": "sha512-2Zks0hf1VLFYI1kbh0I5jP3KHHyCHpkfyHBzsSXRFgl/Bg9mWYfMW8oD+PdMPlEwy5HNsR9JutYy6pMeOh61nw==", + "dev": true, + "license": "MIT", + "dependencies": { + "@jest/expect-utils": "^29.7.0", + "jest-get-type": "^29.6.3", + "jest-matcher-utils": "^29.7.0", + "jest-message-util": "^29.7.0", + "jest-util": "^29.7.0" + }, + "engines": { + "node": "^14.15.0 || ^16.10.0 || >=18.0.0" + } + }, + "node_modules/fast-deep-equal": { + "version": "3.1.3", + "resolved": "https://registry.npmjs.org/fast-deep-equal/-/fast-deep-equal-3.1.3.tgz", + "integrity": "sha512-f3qQ9oQy9j2AhBe/H9VC91wLmKBCCU/gDOnKNAYG5hswO7BLKj09Hc5HYNz9cGI++xlpDCIgDaitVs03ATR84Q==", + "dev": true, + "license": "MIT" + }, + "node_modules/fast-glob": { + "version": "3.3.3", + "resolved": "https://registry.npmjs.org/fast-glob/-/fast-glob-3.3.3.tgz", + "integrity": "sha512-7MptL8U0cqcFdzIzwOTHoilX9x5BrNqye7Z/LuC7kCMRio1EMSyqRK3BEAUD7sXRq4iT4AzTVuZdhgQ2TCvYLg==", + "dev": true, + "license": "MIT", + "dependencies": { + "@nodelib/fs.stat": "^2.0.2", + "@nodelib/fs.walk": "^1.2.3", + "glob-parent": "^5.1.2", + "merge2": "^1.3.0", + "micromatch": "^4.0.8" + }, + "engines": { + "node": ">=8.6.0" + } + }, + "node_modules/fast-json-stable-stringify": { + "version": "2.1.0", + "resolved": "https://registry.npmjs.org/fast-json-stable-stringify/-/fast-json-stable-stringify-2.1.0.tgz", + "integrity": "sha512-lhd/wF+Lk98HZoTCtlVraHtfh5XYijIjalXck7saUtuanSDyLMxnHhSXEDJqHxD7msR8D0uCmqlkwjCV8xvwHw==", + "dev": true, + "license": "MIT" + }, + "node_modules/fast-levenshtein": { + "version": "2.0.6", + "resolved": "https://registry.npmjs.org/fast-levenshtein/-/fast-levenshtein-2.0.6.tgz", + "integrity": "sha512-DCXu6Ifhqcks7TZKY3Hxp3y6qphY5SJZmrWMDrKcERSOXWQdMhU9Ig/PYrzyw/ul9jOIyh0N4M0tbC5hodg8dw==", + "dev": true, + "license": "MIT" + }, + "node_modules/fastest-levenshtein": { + "version": "1.0.16", + "resolved": "https://registry.npmjs.org/fastest-levenshtein/-/fastest-levenshtein-1.0.16.tgz", + "integrity": "sha512-eRnCtTTtGZFpQCwhJiUOuxPQWRXVKYDn0b2PeHfXL6/Zi53SLAzAHfVhVWK2AryC/WH05kGfxhFIPvTF0SXQzg==", + "dev": true, + "license": "MIT", + "engines": { + "node": ">= 4.9.1" + } + }, + "node_modules/fastq": { + "version": "1.19.1", + "resolved": "https://registry.npmjs.org/fastq/-/fastq-1.19.1.tgz", + "integrity": "sha512-GwLTyxkCXjXbxqIhTsMI2Nui8huMPtnxg7krajPJAjnEG/iiOS7i+zCtWGZR9G0NBKbXKh6X9m9UIsYX/N6vvQ==", + "dev": true, + "license": "ISC", + "dependencies": { + "reusify": "^1.0.4" + } + }, + "node_modules/fb-watchman": { + "version": "2.0.2", + "resolved": "https://registry.npmjs.org/fb-watchman/-/fb-watchman-2.0.2.tgz", + "integrity": "sha512-p5161BqbuCaSnB8jIbzQHOlpgsPmK5rJVDfDKO91Axs5NC1uu3HRQm6wt9cd9/+GtQQIO53JdGXXoyDpTAsgYA==", + "dev": true, + "license": "Apache-2.0", + "dependencies": { + "bser": "2.1.1" + } + }, + "node_modules/file-entry-cache": { + "version": "8.0.0", + "resolved": "https://registry.npmjs.org/file-entry-cache/-/file-entry-cache-8.0.0.tgz", + "integrity": "sha512-XXTUwCvisa5oacNGRP9SfNtYBNAMi+RPwBFmblZEF7N7swHYQS6/Zfk7SRwx4D5j3CH211YNRco1DEMNVfZCnQ==", + "dev": true, + "license": "MIT", + "dependencies": { + "flat-cache": "^4.0.0" + }, + "engines": { + "node": ">=16.0.0" + } + }, + "node_modules/fill-range": { + "version": "7.1.1", + "resolved": "https://registry.npmjs.org/fill-range/-/fill-range-7.1.1.tgz", + "integrity": "sha512-YsGpe3WHLK8ZYi4tWDg2Jy3ebRz2rXowDxnld4bkQB00cc/1Zw9AWnC0i9ztDJitivtQvaI9KaLyKrc+hBW0yg==", + "dev": true, + "license": "MIT", + "dependencies": { + "to-regex-range": "^5.0.1" + }, + "engines": { + "node": ">=8" + } + }, + "node_modules/find-up": { + "version": "5.0.0", + "resolved": "https://registry.npmjs.org/find-up/-/find-up-5.0.0.tgz", + "integrity": "sha512-78/PXT1wlLLDgTzDs7sjq9hzz0vXD+zn+7wypEe4fXQxCmdmqfGsEPQxmiCSQI3ajFV91bVSsvNtrJRiW6nGng==", + "dev": true, + "license": "MIT", + "dependencies": { + "locate-path": "^6.0.0", + "path-exists": "^4.0.0" + }, + "engines": { + "node": ">=10" + }, + "funding": { + "url": "https://github.com/sponsors/sindresorhus" + } + }, + "node_modules/flat-cache": { + "version": "4.0.1", + "resolved": "https://registry.npmjs.org/flat-cache/-/flat-cache-4.0.1.tgz", + "integrity": "sha512-f7ccFPK3SXFHpx15UIGyRJ/FJQctuKZ0zVuN3frBo4HnK3cay9VEW0R6yPYFHC0AgqhukPzKjq22t5DmAyqGyw==", + "dev": true, + "license": "MIT", + "dependencies": { + "flatted": "^3.2.9", + "keyv": "^4.5.4" + }, + "engines": { + "node": ">=16" + } + }, + "node_modules/flatted": { + "version": "3.3.3", + "resolved": "https://registry.npmjs.org/flatted/-/flatted-3.3.3.tgz", + "integrity": "sha512-GX+ysw4PBCz0PzosHDepZGANEuFCMLrnRTiEy9McGjmkCQYwRq4A/X786G/fjM/+OjsWSU1ZrY5qyARZmO/uwg==", + "dev": true, + "license": "ISC" + }, + "node_modules/folder-hash": { + "version": "3.3.3", + "resolved": "https://registry.npmjs.org/folder-hash/-/folder-hash-3.3.3.tgz", + "integrity": "sha512-SDgHBgV+RCjrYs8aUwCb9rTgbTVuSdzvFmLaChsLre1yf+D64khCW++VYciaByZ8Rm0uKF8R/XEpXuTRSGUM1A==", + "dev": true, + "license": "MIT", + "dependencies": { + "debug": "^4.1.1", + "graceful-fs": "~4.2.0", + "minimatch": "~3.0.4" + }, + "bin": { + "folder-hash": "bin/folder-hash" + }, + "engines": { + "node": ">=6.0.0" + } + }, + "node_modules/for-each": { + "version": "0.3.5", + "resolved": "https://registry.npmjs.org/for-each/-/for-each-0.3.5.tgz", + "integrity": "sha512-dKx12eRCVIzqCxFGplyFKJMPvLEWgmNtUrpTiJIR5u97zEhRG8ySrtboPHZXx7daLxQVrl643cTzbab2tkQjxg==", + "dev": true, + "license": "MIT", + "dependencies": { + "is-callable": "^1.2.7" + }, + "engines": { + "node": ">= 0.4" + }, + "funding": { + "url": "https://github.com/sponsors/ljharb" + } + }, + "node_modules/form-data": { + "version": "4.0.4", + "resolved": "https://registry.npmjs.org/form-data/-/form-data-4.0.4.tgz", + "integrity": "sha512-KrGhL9Q4zjj0kiUt5OO4Mr/A/jlI2jDYs5eHBpYHPcBEVSiipAvn2Ko2HnPe20rmcuuvMHNdZFp+4IlGTMF0Ow==", + "license": "MIT", + "dependencies": { + "asynckit": "^0.4.0", + "combined-stream": "^1.0.8", + "es-set-tostringtag": "^2.1.0", + "hasown": "^2.0.2", + "mime-types": "^2.1.12" + }, + "engines": { + "node": ">= 6" + } + }, + "node_modules/fs.realpath": { + "version": "1.0.0", + "resolved": "https://registry.npmjs.org/fs.realpath/-/fs.realpath-1.0.0.tgz", + "integrity": "sha512-OO0pH2lK6a0hZnAdau5ItzHPI6pUlvI7jMVnxUQRtw4owF2wk8lOSabtGDCTP4Ggrg2MbGnWO9X8K1t4+fGMDw==", + "dev": true, + "license": "ISC" + }, + "node_modules/fsevents": { + "version": "2.3.3", + "resolved": "https://registry.npmjs.org/fsevents/-/fsevents-2.3.3.tgz", + "integrity": "sha512-5xoDfX+fL7faATnagmWPpbFtwh/R77WmMMqqHGS65C3vvB0YHrgF+B1YmZ3441tMj5n63k0212XNoJwzlhffQw==", + "dev": true, + "hasInstallScript": true, + "license": "MIT", + "optional": true, + "os": [ + "darwin" + ], + "engines": { + "node": "^8.16.0 || ^10.6.0 || >=11.0.0" + } + }, + "node_modules/function-bind": { + "version": "1.1.2", + "resolved": "https://registry.npmjs.org/function-bind/-/function-bind-1.1.2.tgz", + "integrity": "sha512-7XHNxH7qX9xG5mIwxkhumTox/MIRNcOgDrxWsMt2pAr23WHp6MrRlN7FBSFpCpr+oVO0F744iUgR82nJMfG2SA==", + "license": "MIT", + "funding": { + "url": "https://github.com/sponsors/ljharb" + } + }, + "node_modules/function.prototype.name": { + "version": "1.1.8", + "resolved": "https://registry.npmjs.org/function.prototype.name/-/function.prototype.name-1.1.8.tgz", + "integrity": "sha512-e5iwyodOHhbMr/yNrc7fDYG4qlbIvI5gajyzPnb5TCwyhjApznQh1BMFou9b30SevY43gCJKXycoCBjMbsuW0Q==", + "dev": true, + "license": "MIT", + "dependencies": { + "call-bind": "^1.0.8", + "call-bound": "^1.0.3", + "define-properties": "^1.2.1", + "functions-have-names": "^1.2.3", + "hasown": "^2.0.2", + "is-callable": "^1.2.7" + }, + "engines": { + "node": ">= 0.4" + }, + "funding": { + "url": "https://github.com/sponsors/ljharb" + } + }, + "node_modules/functions-have-names": { + "version": "1.2.3", + "resolved": "https://registry.npmjs.org/functions-have-names/-/functions-have-names-1.2.3.tgz", + "integrity": "sha512-xckBUXyTIqT97tq2x2AMb+g163b5JFysYk0x4qxNFwbfQkmNZoiRHb6sPzI9/QV33WeuvVYBUIiD4NzNIyqaRQ==", + "dev": true, + "license": "MIT", + "funding": { + "url": "https://github.com/sponsors/ljharb" + } + }, + "node_modules/gensync": { + "version": "1.0.0-beta.2", + "resolved": "https://registry.npmjs.org/gensync/-/gensync-1.0.0-beta.2.tgz", + "integrity": "sha512-3hN7NaskYvMDLQY55gnW3NQ+mesEAepTqlg+VEbj7zzqEMBVNhzcGYYeqFo/TlYz6eQiFcp1HcsCZO+nGgS8zg==", + "dev": true, + "license": "MIT", + "engines": { + "node": ">=6.9.0" + } + }, + "node_modules/get-caller-file": { + "version": "2.0.5", + "resolved": "https://registry.npmjs.org/get-caller-file/-/get-caller-file-2.0.5.tgz", + "integrity": "sha512-DyFP3BM/3YHTQOCUL/w0OZHR0lpKeGrxotcHWcqNEdnltqFwXVfhEBQ94eIo34AfQpo0rGki4cyIiftY06h2Fg==", + "dev": true, + "license": "ISC", + "engines": { + "node": "6.* || 8.* || >= 10.*" + } + }, + "node_modules/get-intrinsic": { + "version": "1.3.0", + "resolved": "https://registry.npmjs.org/get-intrinsic/-/get-intrinsic-1.3.0.tgz", + "integrity": "sha512-9fSjSaos/fRIVIp+xSJlE6lfwhES7LNtKaCBIamHsjr2na1BiABJPo0mOjjz8GJDURarmCPGqaiVg5mfjb98CQ==", + "license": "MIT", + "dependencies": { + "call-bind-apply-helpers": "^1.0.2", + "es-define-property": "^1.0.1", + "es-errors": "^1.3.0", + "es-object-atoms": "^1.1.1", + "function-bind": "^1.1.2", + "get-proto": "^1.0.1", + "gopd": "^1.2.0", + "has-symbols": "^1.1.0", + "hasown": "^2.0.2", + "math-intrinsics": "^1.1.0" + }, + "engines": { + "node": ">= 0.4" + }, + "funding": { + "url": "https://github.com/sponsors/ljharb" + } + }, + "node_modules/get-package-type": { + "version": "0.1.0", + "resolved": "https://registry.npmjs.org/get-package-type/-/get-package-type-0.1.0.tgz", + "integrity": "sha512-pjzuKtY64GYfWizNAJ0fr9VqttZkNiK2iS430LtIHzjBEr6bX8Am2zm4sW4Ro5wjWW5cAlRL1qAMTcXbjNAO2Q==", + "dev": true, + "license": "MIT", + "engines": { + "node": ">=8.0.0" + } + }, + "node_modules/get-proto": { + "version": "1.0.1", + "resolved": "https://registry.npmjs.org/get-proto/-/get-proto-1.0.1.tgz", + "integrity": "sha512-sTSfBjoXBp89JvIKIefqw7U2CCebsc74kiY6awiGogKtoSGbgjYE/G/+l9sF3MWFPNc9IcoOC4ODfKHfxFmp0g==", + "license": "MIT", + "dependencies": { + "dunder-proto": "^1.0.1", + "es-object-atoms": "^1.0.0" + }, + "engines": { + "node": ">= 0.4" + } + }, + "node_modules/get-stream": { + "version": "5.2.0", + "resolved": "https://registry.npmjs.org/get-stream/-/get-stream-5.2.0.tgz", + "integrity": "sha512-nBF+F1rAZVCu/p7rjzgA+Yb4lfYXrpl7a6VmJrU8wF9I1CKvP/QwPNZHnOlwbTkY6dvtFIzFMSyQXbLoTQPRpA==", + "dev": true, + "license": "MIT", + "dependencies": { + "pump": "^3.0.0" + }, + "engines": { + "node": ">=8" + }, + "funding": { + "url": "https://github.com/sponsors/sindresorhus" + } + }, + "node_modules/get-symbol-description": { + "version": "1.1.0", + "resolved": "https://registry.npmjs.org/get-symbol-description/-/get-symbol-description-1.1.0.tgz", + "integrity": "sha512-w9UMqWwJxHNOvoNzSJ2oPF5wvYcvP7jUvYzhp67yEhTi17ZDBBC1z9pTdGuzjD+EFIqLSYRweZjqfiPzQ06Ebg==", + "dev": true, + "license": "MIT", + "dependencies": { + "call-bound": "^1.0.3", + "es-errors": "^1.3.0", + "get-intrinsic": "^1.2.6" + }, + "engines": { + "node": ">= 0.4" + }, + "funding": { + "url": "https://github.com/sponsors/ljharb" + } + }, + "node_modules/glob": { + "version": "7.2.3", + "resolved": "https://registry.npmjs.org/glob/-/glob-7.2.3.tgz", + "integrity": "sha512-nFR0zLpU2YCaRxwoCJvL6UvCH2JFyFVIvwTLsIf21AuHlMskA1hhTdk+LlYJtOlYt9v6dvszD2BGRqBL+iQK9Q==", + "deprecated": "Glob versions prior to v9 are no longer supported", + "dev": true, + "license": "ISC", + "dependencies": { + "fs.realpath": "^1.0.0", + "inflight": "^1.0.4", + "inherits": "2", + "minimatch": "^3.1.1", + "once": "^1.3.0", + "path-is-absolute": "^1.0.0" + }, + "engines": { + "node": "*" + }, + "funding": { + "url": "https://github.com/sponsors/isaacs" + } + }, + "node_modules/glob-parent": { + "version": "5.1.2", + "resolved": "https://registry.npmjs.org/glob-parent/-/glob-parent-5.1.2.tgz", + "integrity": "sha512-AOIgSQCepiJYwP3ARnGx+5VnTu2HBYdzbGP45eLw1vr3zB3vZLeyed1sC9hnbcOc9/SrMyM5RPQrkGz4aS9Zow==", + "dev": true, + "license": "ISC", + "dependencies": { + "is-glob": "^4.0.1" + }, + "engines": { + "node": ">= 6" + } + }, + "node_modules/glob/node_modules/minimatch": { + "version": "3.1.2", + "resolved": "https://registry.npmjs.org/minimatch/-/minimatch-3.1.2.tgz", + "integrity": "sha512-J7p63hRiAjw1NDEww1W7i37+ByIrOWO5XQQAzZ3VOcL0PNybwpfmV/N05zFAzwQ9USyEcX6t3UO+K5aqBQOIHw==", + "dev": true, + "license": "ISC", + "dependencies": { + "brace-expansion": "^1.1.7" + }, + "engines": { + "node": "*" + } + }, + "node_modules/globals": { + "version": "16.0.0", + "resolved": "https://registry.npmjs.org/globals/-/globals-16.0.0.tgz", + "integrity": "sha512-iInW14XItCXET01CQFqudPOWP2jYMl7T+QRQT+UNcR/iQncN/F0UNpgd76iFkBPgNQb4+X3LV9tLJYzwh+Gl3A==", + "dev": true, + "license": "MIT", + "engines": { + "node": ">=18" + }, + "funding": { + "url": "https://github.com/sponsors/sindresorhus" + } + }, + "node_modules/globalthis": { + "version": "1.0.4", + "resolved": "https://registry.npmjs.org/globalthis/-/globalthis-1.0.4.tgz", + "integrity": "sha512-DpLKbNU4WylpxJykQujfCcwYWiV/Jhm50Goo0wrVILAv5jOr9d+H+UR3PhSCD2rCCEIg0uc+G+muBTwD54JhDQ==", + "dev": true, + "license": "MIT", + "dependencies": { + "define-properties": "^1.2.1", + "gopd": "^1.0.1" + }, + "engines": { + "node": ">= 0.4" + }, + "funding": { + "url": "https://github.com/sponsors/ljharb" + } + }, + "node_modules/gopd": { + "version": "1.2.0", + "resolved": "https://registry.npmjs.org/gopd/-/gopd-1.2.0.tgz", + "integrity": "sha512-ZUKRh6/kUFoAiTAtTYPZJ3hw9wNxx+BIBOijnlG9PnrJsCcSjs1wyyD6vJpaYtgnzDrKYRSqf3OO6Rfa93xsRg==", + "license": "MIT", + "engines": { + "node": ">= 0.4" + }, + "funding": { + "url": "https://github.com/sponsors/ljharb" + } + }, + "node_modules/got": { + "version": "11.8.6", + "resolved": "https://registry.npmjs.org/got/-/got-11.8.6.tgz", + "integrity": "sha512-6tfZ91bOr7bOXnK7PRDCGBLa1H4U080YHNaAQ2KsMGlLEzRbk44nsZF2E1IeRc3vtJHPVbKCYgdFbaGO2ljd8g==", + "dev": true, + "license": "MIT", + "dependencies": { + "@sindresorhus/is": "^4.0.0", + "@szmarczak/http-timer": "^4.0.5", + "@types/cacheable-request": "^6.0.1", + "@types/responselike": "^1.0.0", + "cacheable-lookup": "^5.0.3", + "cacheable-request": "^7.0.2", + "decompress-response": "^6.0.0", + "http2-wrapper": "^1.0.0-beta.5.2", + "lowercase-keys": "^2.0.0", + "p-cancelable": "^2.0.0", + "responselike": "^2.0.0" + }, + "engines": { + "node": ">=10.19.0" + }, + "funding": { + "url": "https://github.com/sindresorhus/got?sponsor=1" + } + }, + "node_modules/graceful-fs": { + "version": "4.2.11", + "resolved": "https://registry.npmjs.org/graceful-fs/-/graceful-fs-4.2.11.tgz", + "integrity": "sha512-RbJ5/jmFcNNCcDV5o9eTnBLJ/HszWV0P73bc+Ff4nS/rJj+YaS6IGyiOL0VoBYX+l1Wrl3k63h/KrH+nhJ0XvQ==", + "dev": true, + "license": "ISC" + }, + "node_modules/guida": { + "version": "0.3.0-alpha", + "resolved": "https://registry.npmjs.org/guida/-/guida-0.3.0-alpha.tgz", + "integrity": "sha512-Cc9yTeCxZcULS+2AdtE+Hb8Mqc50DAFSuJEAZ9AkWRZDXq/nEldNfSjulrpUB29htd+x43FMjCn9Uukr425egg==", + "dev": true, + "license": "BSD-3-Clause", + "dependencies": { + "adm-zip": "^0.5.16", + "form-data": "^4.0.1", + "tmp": "^0.2.3", + "which": "^5.0.0" + }, + "bin": { + "guida": "bin/index.js" + } + }, + "node_modules/has-bigints": { + "version": "1.1.0", + "resolved": "https://registry.npmjs.org/has-bigints/-/has-bigints-1.1.0.tgz", + "integrity": "sha512-R3pbpkcIqv2Pm3dUwgjclDRVmWpTJW2DcMzcIhEXEx1oh/CEMObMm3KLmRJOdvhM7o4uQBnwr8pzRK2sJWIqfg==", + "dev": true, + "license": "MIT", + "engines": { + "node": ">= 0.4" + }, + "funding": { + "url": "https://github.com/sponsors/ljharb" + } + }, + "node_modules/has-flag": { + "version": "4.0.0", + "resolved": "https://registry.npmjs.org/has-flag/-/has-flag-4.0.0.tgz", + "integrity": "sha512-EykJT/Q1KjTWctppgIAgfSO0tKVuZUjhgMr17kqTumMl6Afv3EISleU7qZUzoXDFTAHTDC4NOoG/ZxU3EvlMPQ==", + "dev": true, + "license": "MIT", + "engines": { + "node": ">=8" + } + }, + "node_modules/has-property-descriptors": { + "version": "1.0.2", + "resolved": "https://registry.npmjs.org/has-property-descriptors/-/has-property-descriptors-1.0.2.tgz", + "integrity": "sha512-55JNKuIW+vq4Ke1BjOTjM2YctQIvCT7GFzHwmfZPGo5wnrgkid0YQtnAleFSqumZm4az3n2BS+erby5ipJdgrg==", + "dev": true, + "license": "MIT", + "dependencies": { + "es-define-property": "^1.0.0" + }, + "funding": { + "url": "https://github.com/sponsors/ljharb" + } + }, + "node_modules/has-proto": { + "version": "1.2.0", + "resolved": "https://registry.npmjs.org/has-proto/-/has-proto-1.2.0.tgz", + "integrity": "sha512-KIL7eQPfHQRC8+XluaIw7BHUwwqL19bQn4hzNgdr+1wXoU0KKj6rufu47lhY7KbJR2C6T6+PfyN0Ea7wkSS+qQ==", + "dev": true, + "license": "MIT", + "dependencies": { + "dunder-proto": "^1.0.0" + }, + "engines": { + "node": ">= 0.4" + }, + "funding": { + "url": "https://github.com/sponsors/ljharb" + } + }, + "node_modules/has-symbols": { + "version": "1.1.0", + "resolved": "https://registry.npmjs.org/has-symbols/-/has-symbols-1.1.0.tgz", + "integrity": "sha512-1cDNdwJ2Jaohmb3sg4OmKaMBwuC48sYni5HUw2DvsC8LjGTLK9h+eb1X6RyuOHe4hT0ULCW68iomhjUoKUqlPQ==", + "license": "MIT", + "engines": { + "node": ">= 0.4" + }, + "funding": { + "url": "https://github.com/sponsors/ljharb" + } + }, + "node_modules/has-tostringtag": { + "version": "1.0.2", + "resolved": "https://registry.npmjs.org/has-tostringtag/-/has-tostringtag-1.0.2.tgz", + "integrity": "sha512-NqADB8VjPFLM2V0VvHUewwwsw0ZWBaIdgo+ieHtK3hasLz4qeCRjYcqfB6AQrBggRKppKF8L52/VqdVsO47Dlw==", + "license": "MIT", + "dependencies": { + "has-symbols": "^1.0.3" + }, + "engines": { + "node": ">= 0.4" + }, + "funding": { + "url": "https://github.com/sponsors/ljharb" + } + }, + "node_modules/hasown": { + "version": "2.0.2", + "resolved": "https://registry.npmjs.org/hasown/-/hasown-2.0.2.tgz", + "integrity": "sha512-0hJU9SCPvmMzIBdZFqNPXWa6dqh7WdH0cII9y+CyS8rG3nL48Bclra9HmKhVVUHyPWNH5Y7xDwAB7bfgSjkUMQ==", + "license": "MIT", + "dependencies": { + "function-bind": "^1.1.2" + }, + "engines": { + "node": ">= 0.4" + } + }, + "node_modules/hosted-git-info": { + "version": "2.8.9", + "resolved": "https://registry.npmjs.org/hosted-git-info/-/hosted-git-info-2.8.9.tgz", + "integrity": "sha512-mxIDAb9Lsm6DoOJ7xH+5+X4y1LU/4Hi50L9C5sIswK3JzULS4bwk1FvjdBgvYR4bzT4tuUQiC15FE2f5HbLvYw==", + "dev": true, + "license": "ISC" + }, + "node_modules/html-escaper": { + "version": "2.0.2", + "resolved": "https://registry.npmjs.org/html-escaper/-/html-escaper-2.0.2.tgz", + "integrity": "sha512-H2iMtd0I4Mt5eYiapRdIDjp+XzelXQ0tFE4JS7YFwFevXXMmOp9myNrUvCg0D6ws8iqkRPBfKHgbwig1SmlLfg==", + "dev": true, + "license": "MIT" + }, + "node_modules/http-cache-semantics": { + "version": "4.1.1", + "resolved": "https://registry.npmjs.org/http-cache-semantics/-/http-cache-semantics-4.1.1.tgz", + "integrity": "sha512-er295DKPVsV82j5kw1Gjt+ADA/XYHsajl82cGNQG2eyoPkvgUhX+nDIyelzhIWbbsXP39EHcI6l5tYs2FYqYXQ==", + "dev": true, + "license": "BSD-2-Clause" + }, + "node_modules/http2-wrapper": { + "version": "1.0.3", + "resolved": "https://registry.npmjs.org/http2-wrapper/-/http2-wrapper-1.0.3.tgz", + "integrity": "sha512-V+23sDMr12Wnz7iTcDeJr3O6AIxlnvT/bmaAAAP/Xda35C90p9599p0F1eHR/N1KILWSoWVAiOMFjBBXaXSMxg==", + "dev": true, + "license": "MIT", + "dependencies": { + "quick-lru": "^5.1.1", + "resolve-alpn": "^1.0.0" + }, + "engines": { + "node": ">=10.19.0" + } + }, + "node_modules/human-signals": { + "version": "2.1.0", + "resolved": "https://registry.npmjs.org/human-signals/-/human-signals-2.1.0.tgz", + "integrity": "sha512-B4FFZ6q/T2jhhksgkbEW3HBvWIfDW85snkQgawt07S7J5QXTk6BkNV+0yAeZrM5QpMAdYlocGoljn0sJ/WQkFw==", + "dev": true, + "license": "Apache-2.0", + "engines": { + "node": ">=10.17.0" + } + }, + "node_modules/ieee754": { + "version": "1.2.1", + "resolved": "https://registry.npmjs.org/ieee754/-/ieee754-1.2.1.tgz", + "integrity": "sha512-dcyqhDvX1C46lXZcVqCpK+FtMRQVdIMN6/Df5js2zouUsqG7I6sFxitIC+7KYK29KdXOLHdu9zL4sFnoVQnqaA==", + "dev": true, + "funding": [ + { + "type": "github", + "url": "https://github.com/sponsors/feross" + }, + { + "type": "patreon", + "url": "https://www.patreon.com/feross" + }, + { + "type": "consulting", + "url": "https://feross.org/support" + } + ], + "license": "BSD-3-Clause" + }, + "node_modules/ignore": { + "version": "5.3.2", + "resolved": "https://registry.npmjs.org/ignore/-/ignore-5.3.2.tgz", + "integrity": "sha512-hsBTNUqQTDwkWtcdYI2i06Y/nUBEsNEDJKjWdigLvegy8kDuJAS8uRlpkkcQpyEXL0Z/pjDy5HBmMjRCJ2gq+g==", + "dev": true, + "license": "MIT", + "engines": { + "node": ">= 4" + } + }, + "node_modules/immediate": { + "version": "3.0.6", + "resolved": "https://registry.npmjs.org/immediate/-/immediate-3.0.6.tgz", + "integrity": "sha512-XXOFtyqDjNDAQxVfYxuF7g9Il/IbWmmlQg2MYKOH8ExIT1qg6xc4zyS3HaEEATgs1btfzxq15ciUiY7gjSXRGQ==", + "license": "MIT" + }, + "node_modules/import-fresh": { + "version": "3.3.1", + "resolved": "https://registry.npmjs.org/import-fresh/-/import-fresh-3.3.1.tgz", + "integrity": "sha512-TR3KfrTZTYLPB6jUjfx6MF9WcWrHL9su5TObK4ZkYgBdWKPOFoSoQIdEuTuR82pmtxH2spWG9h6etwfr1pLBqQ==", + "dev": true, + "license": "MIT", + "dependencies": { + "parent-module": "^1.0.0", + "resolve-from": "^4.0.0" + }, + "engines": { + "node": ">=6" + }, + "funding": { + "url": "https://github.com/sponsors/sindresorhus" + } + }, + "node_modules/import-fresh/node_modules/resolve-from": { + "version": "4.0.0", + "resolved": "https://registry.npmjs.org/resolve-from/-/resolve-from-4.0.0.tgz", + "integrity": "sha512-pb/MYmXstAkysRFx8piNI1tGFNQIFA3vkE3Gq4EuA1dF6gHp/+vgZqsCGJapvy8N3Q+4o7FwvquPJcnZ7RYy4g==", + "dev": true, + "license": "MIT", + "engines": { + "node": ">=4" + } + }, + "node_modules/import-local": { + "version": "3.2.0", + "resolved": "https://registry.npmjs.org/import-local/-/import-local-3.2.0.tgz", + "integrity": "sha512-2SPlun1JUPWoM6t3F0dw0FkCF/jWY8kttcY4f599GLTSjh2OCuuhdTkJQsEcZzBqbXZGKMK2OqW1oZsjtf/gQA==", + "dev": true, + "license": "MIT", + "dependencies": { + "pkg-dir": "^4.2.0", + "resolve-cwd": "^3.0.0" + }, + "bin": { + "import-local-fixture": "fixtures/cli.js" + }, + "engines": { + "node": ">=8" + }, + "funding": { + "url": "https://github.com/sponsors/sindresorhus" + } + }, + "node_modules/imurmurhash": { + "version": "0.1.4", + "resolved": "https://registry.npmjs.org/imurmurhash/-/imurmurhash-0.1.4.tgz", + "integrity": "sha512-JmXMZ6wuvDmLiHEml9ykzqO6lwFbof0GG4IkcGaENdCRDDmMVnny7s5HsIgHCbaq0w2MyPhDqkhTUgS2LU2PHA==", + "dev": true, + "license": "MIT", + "engines": { + "node": ">=0.8.19" + } + }, + "node_modules/indexeddb-fs": { + "version": "2.1.5", + "resolved": "https://registry.npmjs.org/indexeddb-fs/-/indexeddb-fs-2.1.5.tgz", + "integrity": "sha512-4TDdof4ou+l1P3O9D+U09DAc2VQ/bWzgKBxC3nQ9qqMhNR2Y3p8JDgELzkY3bwLP8JULMTf2UHsjnYpiKExH2w==", + "license": "MIT", + "dependencies": { + "jsonschema": "^1.4.1" + } + }, + "node_modules/inflight": { + "version": "1.0.6", + "resolved": "https://registry.npmjs.org/inflight/-/inflight-1.0.6.tgz", + "integrity": "sha512-k92I/b08q4wvFscXCLvqfsHCrjrF7yiXsQuIVvVE7N82W3+aqpzuUdBbfhWcy/FZR3/4IgflMgKLOsvPDrGCJA==", + "deprecated": "This module is not supported, and leaks memory. Do not use it. Check out lru-cache if you want a good and tested way to coalesce async requests by a key value, which is much more comprehensive and powerful.", + "dev": true, + "license": "ISC", + "dependencies": { + "once": "^1.3.0", + "wrappy": "1" + } + }, + "node_modules/inherits": { + "version": "2.0.4", + "resolved": "https://registry.npmjs.org/inherits/-/inherits-2.0.4.tgz", + "integrity": "sha512-k/vGaX4/Yla3WzyMCvTQOXYeIHvqOKtnqBduzTHpzpQZzAskKMhZ2K+EnBiSM9zGSoIFeMpXKxa4dYeZIQqewQ==", + "license": "ISC" + }, + "node_modules/internal-slot": { + "version": "1.1.0", + "resolved": "https://registry.npmjs.org/internal-slot/-/internal-slot-1.1.0.tgz", + "integrity": "sha512-4gd7VpWNQNB4UKKCFFVcp1AVv+FMOgs9NKzjHKusc8jTMhd5eL1NqQqOpE0KzMds804/yHlglp3uxgluOqAPLw==", + "dev": true, + "license": "MIT", + "dependencies": { + "es-errors": "^1.3.0", + "hasown": "^2.0.2", + "side-channel": "^1.1.0" + }, + "engines": { + "node": ">= 0.4" + } + }, + "node_modules/is-array-buffer": { + "version": "3.0.5", + "resolved": "https://registry.npmjs.org/is-array-buffer/-/is-array-buffer-3.0.5.tgz", + "integrity": "sha512-DDfANUiiG2wC1qawP66qlTugJeL5HyzMpfr8lLK+jMQirGzNod0B12cFB/9q838Ru27sBwfw78/rdoU7RERz6A==", + "dev": true, + "license": "MIT", + "dependencies": { + "call-bind": "^1.0.8", + "call-bound": "^1.0.3", + "get-intrinsic": "^1.2.6" + }, + "engines": { + "node": ">= 0.4" + }, + "funding": { + "url": "https://github.com/sponsors/ljharb" + } + }, + "node_modules/is-arrayish": { + "version": "0.2.1", + "resolved": "https://registry.npmjs.org/is-arrayish/-/is-arrayish-0.2.1.tgz", + "integrity": "sha512-zz06S8t0ozoDXMG+ube26zeCTNXcKIPJZJi8hBrF4idCLms4CG9QtK7qBl1boi5ODzFpjswb5JPmHCbMpjaYzg==", + "dev": true, + "license": "MIT" + }, + "node_modules/is-async-function": { + "version": "2.1.1", + "resolved": "https://registry.npmjs.org/is-async-function/-/is-async-function-2.1.1.tgz", + "integrity": "sha512-9dgM/cZBnNvjzaMYHVoxxfPj2QXt22Ev7SuuPrs+xav0ukGB0S6d4ydZdEiM48kLx5kDV+QBPrpVnFyefL8kkQ==", + "dev": true, + "license": "MIT", + "dependencies": { + "async-function": "^1.0.0", + "call-bound": "^1.0.3", + "get-proto": "^1.0.1", + "has-tostringtag": "^1.0.2", + "safe-regex-test": "^1.1.0" + }, + "engines": { + "node": ">= 0.4" + }, + "funding": { + "url": "https://github.com/sponsors/ljharb" + } + }, + "node_modules/is-bigint": { + "version": "1.1.0", + "resolved": "https://registry.npmjs.org/is-bigint/-/is-bigint-1.1.0.tgz", + "integrity": "sha512-n4ZT37wG78iz03xPRKJrHTdZbe3IicyucEtdRsV5yglwc3GyUfbAfpSeD0FJ41NbUNSt5wbhqfp1fS+BgnvDFQ==", + "dev": true, + "license": "MIT", + "dependencies": { + "has-bigints": "^1.0.2" + }, + "engines": { + "node": ">= 0.4" + }, + "funding": { + "url": "https://github.com/sponsors/ljharb" + } + }, + "node_modules/is-binary-path": { + "version": "2.1.0", + "resolved": "https://registry.npmjs.org/is-binary-path/-/is-binary-path-2.1.0.tgz", + "integrity": "sha512-ZMERYes6pDydyuGidse7OsHxtbI7WVeUEozgR/g7rd0xUimYNlvZRE/K2MgZTjWy725IfelLeVcEM97mmtRGXw==", + "dev": true, + "license": "MIT", + "dependencies": { + "binary-extensions": "^2.0.0" + }, + "engines": { + "node": ">=8" + } + }, + "node_modules/is-boolean-object": { + "version": "1.2.2", + "resolved": "https://registry.npmjs.org/is-boolean-object/-/is-boolean-object-1.2.2.tgz", + "integrity": "sha512-wa56o2/ElJMYqjCjGkXri7it5FbebW5usLw/nPmCMs5DeZ7eziSYZhSmPRn0txqeW4LnAmQQU7FgqLpsEFKM4A==", + "dev": true, + "license": "MIT", + "dependencies": { + "call-bound": "^1.0.3", + "has-tostringtag": "^1.0.2" + }, + "engines": { + "node": ">= 0.4" + }, + "funding": { + "url": "https://github.com/sponsors/ljharb" + } + }, + "node_modules/is-callable": { + "version": "1.2.7", + "resolved": "https://registry.npmjs.org/is-callable/-/is-callable-1.2.7.tgz", + "integrity": "sha512-1BC0BVFhS/p0qtw6enp8e+8OD0UrK0oFLztSjNzhcKA3WDuJxxAPXzPuPtKkjEY9UUoEWlX/8fgKeu2S8i9JTA==", + "dev": true, + "license": "MIT", + "engines": { + "node": ">= 0.4" + }, + "funding": { + "url": "https://github.com/sponsors/ljharb" + } + }, + "node_modules/is-core-module": { + "version": "2.16.1", + "resolved": "https://registry.npmjs.org/is-core-module/-/is-core-module-2.16.1.tgz", + "integrity": "sha512-UfoeMA6fIJ8wTYFEUjelnaGI67v6+N7qXJEvQuIGa99l4xsCruSYOVSQ0uPANn4dAzm8lkYPaKLrrijLq7x23w==", + "dev": true, + "license": "MIT", + "dependencies": { + "hasown": "^2.0.2" + }, + "engines": { + "node": ">= 0.4" + }, + "funding": { + "url": "https://github.com/sponsors/ljharb" + } + }, + "node_modules/is-data-view": { + "version": "1.0.2", + "resolved": "https://registry.npmjs.org/is-data-view/-/is-data-view-1.0.2.tgz", + "integrity": "sha512-RKtWF8pGmS87i2D6gqQu/l7EYRlVdfzemCJN/P3UOs//x1QE7mfhvzHIApBTRf7axvT6DMGwSwBXYCT0nfB9xw==", + "dev": true, + "license": "MIT", + "dependencies": { + "call-bound": "^1.0.2", + "get-intrinsic": "^1.2.6", + "is-typed-array": "^1.1.13" + }, + "engines": { + "node": ">= 0.4" + }, + "funding": { + "url": "https://github.com/sponsors/ljharb" + } + }, + "node_modules/is-date-object": { + "version": "1.1.0", + "resolved": "https://registry.npmjs.org/is-date-object/-/is-date-object-1.1.0.tgz", + "integrity": "sha512-PwwhEakHVKTdRNVOw+/Gyh0+MzlCl4R6qKvkhuvLtPMggI1WAHt9sOwZxQLSGpUaDnrdyDsomoRgNnCfKNSXXg==", + "dev": true, + "license": "MIT", + "dependencies": { + "call-bound": "^1.0.2", + "has-tostringtag": "^1.0.2" + }, + "engines": { + "node": ">= 0.4" + }, + "funding": { + "url": "https://github.com/sponsors/ljharb" + } + }, + "node_modules/is-extglob": { + "version": "2.1.1", + "resolved": "https://registry.npmjs.org/is-extglob/-/is-extglob-2.1.1.tgz", + "integrity": "sha512-SbKbANkN603Vi4jEZv49LeVJMn4yGwsbzZworEoyEiutsN3nJYdbO36zfhGJ6QEDpOZIFkDtnq5JRxmvl3jsoQ==", + "dev": true, + "license": "MIT", + "engines": { + "node": ">=0.10.0" + } + }, + "node_modules/is-finalizationregistry": { + "version": "1.1.1", + "resolved": "https://registry.npmjs.org/is-finalizationregistry/-/is-finalizationregistry-1.1.1.tgz", + "integrity": "sha512-1pC6N8qWJbWoPtEjgcL2xyhQOP491EQjeUo3qTKcmV8YSDDJrOepfG8pcC7h/QgnQHYSv0mJ3Z/ZWxmatVrysg==", + "dev": true, + "license": "MIT", + "dependencies": { + "call-bound": "^1.0.3" + }, + "engines": { + "node": ">= 0.4" + }, + "funding": { + "url": "https://github.com/sponsors/ljharb" + } + }, + "node_modules/is-fullwidth-code-point": { + "version": "3.0.0", + "resolved": "https://registry.npmjs.org/is-fullwidth-code-point/-/is-fullwidth-code-point-3.0.0.tgz", + "integrity": "sha512-zymm5+u+sCsSWyD9qNaejV3DFvhCKclKdizYaJUuHA83RLjb7nSuGnddCHGv0hk+KY7BMAlsWeK4Ueg6EV6XQg==", + "dev": true, + "license": "MIT", + "engines": { + "node": ">=8" + } + }, + "node_modules/is-generator-fn": { + "version": "2.1.0", + "resolved": "https://registry.npmjs.org/is-generator-fn/-/is-generator-fn-2.1.0.tgz", + "integrity": "sha512-cTIB4yPYL/Grw0EaSzASzg6bBy9gqCofvWN8okThAYIxKJZC+udlRAmGbM0XLeniEJSs8uEgHPGuHSe1XsOLSQ==", + "dev": true, + "license": "MIT", + "engines": { + "node": ">=6" + } + }, + "node_modules/is-generator-function": { + "version": "1.1.0", + "resolved": "https://registry.npmjs.org/is-generator-function/-/is-generator-function-1.1.0.tgz", + "integrity": "sha512-nPUB5km40q9e8UfN/Zc24eLlzdSf9OfKByBw9CIdw4H1giPMeA0OIJvbchsCu4npfI2QcMVBsGEBHKZ7wLTWmQ==", + "dev": true, + "license": "MIT", + "dependencies": { + "call-bound": "^1.0.3", + "get-proto": "^1.0.0", + "has-tostringtag": "^1.0.2", + "safe-regex-test": "^1.1.0" + }, + "engines": { + "node": ">= 0.4" + }, + "funding": { + "url": "https://github.com/sponsors/ljharb" + } + }, + "node_modules/is-glob": { + "version": "4.0.3", + "resolved": "https://registry.npmjs.org/is-glob/-/is-glob-4.0.3.tgz", + "integrity": "sha512-xelSayHH36ZgE7ZWhli7pW34hNbNl8Ojv5KVmkJD4hBdD3th8Tfk9vYasLM+mXWOZhFkgZfxhLSnrwRr4elSSg==", + "dev": true, + "license": "MIT", + "dependencies": { + "is-extglob": "^2.1.1" + }, + "engines": { + "node": ">=0.10.0" + } + }, + "node_modules/is-interactive": { + "version": "1.0.0", + "resolved": "https://registry.npmjs.org/is-interactive/-/is-interactive-1.0.0.tgz", + "integrity": "sha512-2HvIEKRoqS62guEC+qBjpvRubdX910WCMuJTZ+I9yvqKU2/12eSL549HMwtabb4oupdj2sMP50k+XJfB/8JE6w==", + "dev": true, + "license": "MIT", + "engines": { + "node": ">=8" + } + }, + "node_modules/is-map": { + "version": "2.0.3", + "resolved": "https://registry.npmjs.org/is-map/-/is-map-2.0.3.tgz", + "integrity": "sha512-1Qed0/Hr2m+YqxnM09CjA2d/i6YZNfF6R2oRAOj36eUdS6qIV/huPJNSEpKbupewFs+ZsJlxsjjPbc0/afW6Lw==", + "dev": true, + "license": "MIT", + "engines": { + "node": ">= 0.4" + }, + "funding": { + "url": "https://github.com/sponsors/ljharb" + } + }, + "node_modules/is-number": { + "version": "7.0.0", + "resolved": "https://registry.npmjs.org/is-number/-/is-number-7.0.0.tgz", + "integrity": "sha512-41Cifkg6e8TylSpdtTpeLVMqvSBEVzTttHvERD741+pnZ8ANv0004MRL43QKPDlK9cGvNp6NZWZUBlbGXYxxng==", + "dev": true, + "license": "MIT", + "engines": { + "node": ">=0.12.0" + } + }, + "node_modules/is-number-object": { + "version": "1.1.1", + "resolved": "https://registry.npmjs.org/is-number-object/-/is-number-object-1.1.1.tgz", + "integrity": "sha512-lZhclumE1G6VYD8VHe35wFaIif+CTy5SJIi5+3y4psDgWu4wPDoBhF8NxUOinEc7pHgiTsT6MaBb92rKhhD+Xw==", + "dev": true, + "license": "MIT", + "dependencies": { + "call-bound": "^1.0.3", + "has-tostringtag": "^1.0.2" + }, + "engines": { + "node": ">= 0.4" + }, + "funding": { + "url": "https://github.com/sponsors/ljharb" + } + }, + "node_modules/is-regex": { + "version": "1.2.1", + "resolved": "https://registry.npmjs.org/is-regex/-/is-regex-1.2.1.tgz", + "integrity": "sha512-MjYsKHO5O7mCsmRGxWcLWheFqN9DJ/2TmngvjKXihe6efViPqc274+Fx/4fYj/r03+ESvBdTXK0V6tA3rgez1g==", + "dev": true, + "license": "MIT", + "dependencies": { + "call-bound": "^1.0.2", + "gopd": "^1.2.0", + "has-tostringtag": "^1.0.2", + "hasown": "^2.0.2" + }, + "engines": { + "node": ">= 0.4" + }, + "funding": { + "url": "https://github.com/sponsors/ljharb" + } + }, + "node_modules/is-set": { + "version": "2.0.3", + "resolved": "https://registry.npmjs.org/is-set/-/is-set-2.0.3.tgz", + "integrity": "sha512-iPAjerrse27/ygGLxw+EBR9agv9Y6uLeYVJMu+QNCoouJ1/1ri0mGrcWpfCqFZuzzx3WjtwxG098X+n4OuRkPg==", + "dev": true, + "license": "MIT", + "engines": { + "node": ">= 0.4" + }, + "funding": { + "url": "https://github.com/sponsors/ljharb" + } + }, + "node_modules/is-shared-array-buffer": { + "version": "1.0.4", + "resolved": "https://registry.npmjs.org/is-shared-array-buffer/-/is-shared-array-buffer-1.0.4.tgz", + "integrity": "sha512-ISWac8drv4ZGfwKl5slpHG9OwPNty4jOWPRIhBpxOoD+hqITiwuipOQ2bNthAzwA3B4fIjO4Nln74N0S9byq8A==", + "dev": true, + "license": "MIT", + "dependencies": { + "call-bound": "^1.0.3" + }, + "engines": { + "node": ">= 0.4" + }, + "funding": { + "url": "https://github.com/sponsors/ljharb" + } + }, + "node_modules/is-stream": { + "version": "2.0.1", + "resolved": "https://registry.npmjs.org/is-stream/-/is-stream-2.0.1.tgz", + "integrity": "sha512-hFoiJiTl63nn+kstHGBtewWSKnQLpyb155KHheA1l39uvtO9nWIop1p3udqPcUd/xbF1VLMO4n7OI6p7RbngDg==", + "dev": true, + "license": "MIT", + "engines": { + "node": ">=8" + }, + "funding": { + "url": "https://github.com/sponsors/sindresorhus" + } + }, + "node_modules/is-string": { + "version": "1.1.1", + "resolved": "https://registry.npmjs.org/is-string/-/is-string-1.1.1.tgz", + "integrity": "sha512-BtEeSsoaQjlSPBemMQIrY1MY0uM6vnS1g5fmufYOtnxLGUZM2178PKbhsk7Ffv58IX+ZtcvoGwccYsh0PglkAA==", + "dev": true, + "license": "MIT", + "dependencies": { + "call-bound": "^1.0.3", + "has-tostringtag": "^1.0.2" + }, + "engines": { + "node": ">= 0.4" + }, + "funding": { + "url": "https://github.com/sponsors/ljharb" + } + }, + "node_modules/is-symbol": { + "version": "1.1.1", + "resolved": "https://registry.npmjs.org/is-symbol/-/is-symbol-1.1.1.tgz", + "integrity": "sha512-9gGx6GTtCQM73BgmHQXfDmLtfjjTUDSyoxTCbp5WtoixAhfgsDirWIcVQ/IHpvI5Vgd5i/J5F7B9cN/WlVbC/w==", + "dev": true, + "license": "MIT", + "dependencies": { + "call-bound": "^1.0.2", + "has-symbols": "^1.1.0", + "safe-regex-test": "^1.1.0" + }, + "engines": { + "node": ">= 0.4" + }, + "funding": { + "url": "https://github.com/sponsors/ljharb" + } + }, + "node_modules/is-typed-array": { + "version": "1.1.15", + "resolved": "https://registry.npmjs.org/is-typed-array/-/is-typed-array-1.1.15.tgz", + "integrity": "sha512-p3EcsicXjit7SaskXHs1hA91QxgTw46Fv6EFKKGS5DRFLD8yKnohjF3hxoju94b/OcMZoQukzpPpBE9uLVKzgQ==", + "dev": true, + "license": "MIT", + "dependencies": { + "which-typed-array": "^1.1.16" + }, + "engines": { + "node": ">= 0.4" + }, + "funding": { + "url": "https://github.com/sponsors/ljharb" + } + }, + "node_modules/is-unicode-supported": { + "version": "0.1.0", + "resolved": "https://registry.npmjs.org/is-unicode-supported/-/is-unicode-supported-0.1.0.tgz", + "integrity": "sha512-knxG2q4UC3u8stRGyAVJCOdxFmv5DZiRcdlIaAQXAbSfJya+OhopNotLQrstBhququ4ZpuKbDc/8S6mgXgPFPw==", + "dev": true, + "license": "MIT", + "engines": { + "node": ">=10" + }, + "funding": { + "url": "https://github.com/sponsors/sindresorhus" + } + }, + "node_modules/is-weakmap": { + "version": "2.0.2", + "resolved": "https://registry.npmjs.org/is-weakmap/-/is-weakmap-2.0.2.tgz", + "integrity": "sha512-K5pXYOm9wqY1RgjpL3YTkF39tni1XajUIkawTLUo9EZEVUFga5gSQJF8nNS7ZwJQ02y+1YCNYcMh+HIf1ZqE+w==", + "dev": true, + "license": "MIT", + "engines": { + "node": ">= 0.4" + }, + "funding": { + "url": "https://github.com/sponsors/ljharb" + } + }, + "node_modules/is-weakref": { + "version": "1.1.1", + "resolved": "https://registry.npmjs.org/is-weakref/-/is-weakref-1.1.1.tgz", + "integrity": "sha512-6i9mGWSlqzNMEqpCp93KwRS1uUOodk2OJ6b+sq7ZPDSy2WuI5NFIxp/254TytR8ftefexkWn5xNiHUNpPOfSew==", + "dev": true, + "license": "MIT", + "dependencies": { + "call-bound": "^1.0.3" + }, + "engines": { + "node": ">= 0.4" + }, + "funding": { + "url": "https://github.com/sponsors/ljharb" + } + }, + "node_modules/is-weakset": { + "version": "2.0.4", + "resolved": "https://registry.npmjs.org/is-weakset/-/is-weakset-2.0.4.tgz", + "integrity": "sha512-mfcwb6IzQyOKTs84CQMrOwW4gQcaTOAWJ0zzJCl2WSPDrWk/OzDaImWFH3djXhb24g4eudZfLRozAvPGw4d9hQ==", + "dev": true, + "license": "MIT", + "dependencies": { + "call-bound": "^1.0.3", + "get-intrinsic": "^1.2.6" + }, + "engines": { + "node": ">= 0.4" + }, + "funding": { + "url": "https://github.com/sponsors/ljharb" + } + }, + "node_modules/isarray": { + "version": "2.0.5", + "resolved": "https://registry.npmjs.org/isarray/-/isarray-2.0.5.tgz", + "integrity": "sha512-xHjhDr3cNBK0BzdUJSPXZntQUx/mwMS5Rw4A7lPJ90XGAO6ISP/ePDNuo0vhqOZU+UD5JoodwCAAoZQd3FeAKw==", + "dev": true, + "license": "MIT" + }, + "node_modules/isexe": { + "version": "3.1.1", + "resolved": "https://registry.npmjs.org/isexe/-/isexe-3.1.1.tgz", + "integrity": "sha512-LpB/54B+/2J5hqQ7imZHfdU31OlgQqx7ZicVlkm9kzg9/w8GKLEcFfJl/t7DCEDueOyBAD6zCCwTO6Fzs0NoEQ==", + "license": "ISC", + "engines": { + "node": ">=16" + } + }, + "node_modules/istanbul-lib-coverage": { + "version": "3.2.2", + "resolved": "https://registry.npmjs.org/istanbul-lib-coverage/-/istanbul-lib-coverage-3.2.2.tgz", + "integrity": "sha512-O8dpsF+r0WV/8MNRKfnmrtCWhuKjxrq2w+jpzBL5UZKTi2LeVWnWOmWRxFlesJONmc+wLAGvKQZEOanko0LFTg==", + "dev": true, + "license": "BSD-3-Clause", + "engines": { + "node": ">=8" + } + }, + "node_modules/istanbul-lib-instrument": { + "version": "6.0.3", + "resolved": "https://registry.npmjs.org/istanbul-lib-instrument/-/istanbul-lib-instrument-6.0.3.tgz", + "integrity": "sha512-Vtgk7L/R2JHyyGW07spoFlB8/lpjiOLTjMdms6AFMraYt3BaJauod/NGrfnVG/y4Ix1JEuMRPDPEj2ua+zz1/Q==", + "dev": true, + "license": "BSD-3-Clause", + "dependencies": { + "@babel/core": "^7.23.9", + "@babel/parser": "^7.23.9", + "@istanbuljs/schema": "^0.1.3", + "istanbul-lib-coverage": "^3.2.0", + "semver": "^7.5.4" + }, + "engines": { + "node": ">=10" + } + }, + "node_modules/istanbul-lib-instrument/node_modules/semver": { + "version": "7.7.1", + "resolved": "https://registry.npmjs.org/semver/-/semver-7.7.1.tgz", + "integrity": "sha512-hlq8tAfn0m/61p4BVRcPzIGr6LKiMwo4VM6dGi6pt4qcRkmNzTcWq6eCEjEh+qXjkMDvPlOFFSGwQjoEa6gyMA==", + "dev": true, + "license": "ISC", + "bin": { + "semver": "bin/semver.js" + }, + "engines": { + "node": ">=10" + } + }, + "node_modules/istanbul-lib-report": { + "version": "3.0.1", + "resolved": "https://registry.npmjs.org/istanbul-lib-report/-/istanbul-lib-report-3.0.1.tgz", + "integrity": "sha512-GCfE1mtsHGOELCU8e/Z7YWzpmybrx/+dSTfLrvY8qRmaY6zXTKWn6WQIjaAFw069icm6GVMNkgu0NzI4iPZUNw==", + "dev": true, + "license": "BSD-3-Clause", + "dependencies": { + "istanbul-lib-coverage": "^3.0.0", + "make-dir": "^4.0.0", + "supports-color": "^7.1.0" + }, + "engines": { + "node": ">=10" + } + }, + "node_modules/istanbul-lib-source-maps": { + "version": "4.0.1", + "resolved": "https://registry.npmjs.org/istanbul-lib-source-maps/-/istanbul-lib-source-maps-4.0.1.tgz", + "integrity": "sha512-n3s8EwkdFIJCG3BPKBYvskgXGoy88ARzvegkitk60NxRdwltLOTaH7CUiMRXvwYorl0Q712iEjcWB+fK/MrWVw==", + "dev": true, + "license": "BSD-3-Clause", + "dependencies": { + "debug": "^4.1.1", + "istanbul-lib-coverage": "^3.0.0", + "source-map": "^0.6.1" + }, + "engines": { + "node": ">=10" + } + }, + "node_modules/istanbul-reports": { + "version": "3.1.7", + "resolved": "https://registry.npmjs.org/istanbul-reports/-/istanbul-reports-3.1.7.tgz", + "integrity": "sha512-BewmUXImeuRk2YY0PVbxgKAysvhRPUQE0h5QRM++nVWyubKGV0l8qQ5op8+B2DOmwSe63Jivj0BjkPQVf8fP5g==", + "dev": true, + "license": "BSD-3-Clause", + "dependencies": { + "html-escaper": "^2.0.0", + "istanbul-lib-report": "^3.0.0" + }, + "engines": { + "node": ">=8" + } + }, + "node_modules/jest": { + "version": "29.7.0", + "resolved": "https://registry.npmjs.org/jest/-/jest-29.7.0.tgz", + "integrity": "sha512-NIy3oAFp9shda19hy4HK0HRTWKtPJmGdnvywu01nOqNC2vZg+Z+fvJDxpMQA88eb2I9EcafcdjYgsDthnYTvGw==", + "dev": true, + "license": "MIT", + "dependencies": { + "@jest/core": "^29.7.0", + "@jest/types": "^29.6.3", + "import-local": "^3.0.2", + "jest-cli": "^29.7.0" + }, + "bin": { + "jest": "bin/jest.js" + }, + "engines": { + "node": "^14.15.0 || ^16.10.0 || >=18.0.0" + }, + "peerDependencies": { + "node-notifier": "^8.0.1 || ^9.0.0 || ^10.0.0" + }, + "peerDependenciesMeta": { + "node-notifier": { + "optional": true + } + } + }, + "node_modules/jest-changed-files": { + "version": "29.7.0", + "resolved": "https://registry.npmjs.org/jest-changed-files/-/jest-changed-files-29.7.0.tgz", + "integrity": "sha512-fEArFiwf1BpQ+4bXSprcDc3/x4HSzL4al2tozwVpDFpsxALjLYdyiIK4e5Vz66GQJIbXJ82+35PtysofptNX2w==", + "dev": true, + "license": "MIT", + "dependencies": { + "execa": "^5.0.0", + "jest-util": "^29.7.0", + "p-limit": "^3.1.0" + }, + "engines": { + "node": "^14.15.0 || ^16.10.0 || >=18.0.0" + } + }, + "node_modules/jest-circus": { + "version": "29.7.0", + "resolved": "https://registry.npmjs.org/jest-circus/-/jest-circus-29.7.0.tgz", + "integrity": "sha512-3E1nCMgipcTkCocFwM90XXQab9bS+GMsjdpmPrlelaxwD93Ad8iVEjX/vvHPdLPnFf+L40u+5+iutRdA1N9myw==", + "dev": true, + "license": "MIT", + "dependencies": { + "@jest/environment": "^29.7.0", + "@jest/expect": "^29.7.0", + "@jest/test-result": "^29.7.0", + "@jest/types": "^29.6.3", + "@types/node": "*", + "chalk": "^4.0.0", + "co": "^4.6.0", + "dedent": "^1.0.0", + "is-generator-fn": "^2.0.0", + "jest-each": "^29.7.0", + "jest-matcher-utils": "^29.7.0", + "jest-message-util": "^29.7.0", + "jest-runtime": "^29.7.0", + "jest-snapshot": "^29.7.0", + "jest-util": "^29.7.0", + "p-limit": "^3.1.0", + "pretty-format": "^29.7.0", + "pure-rand": "^6.0.0", + "slash": "^3.0.0", + "stack-utils": "^2.0.3" + }, + "engines": { + "node": "^14.15.0 || ^16.10.0 || >=18.0.0" + } + }, + "node_modules/jest-cli": { + "version": "29.7.0", + "resolved": "https://registry.npmjs.org/jest-cli/-/jest-cli-29.7.0.tgz", + "integrity": "sha512-OVVobw2IubN/GSYsxETi+gOe7Ka59EFMR/twOU3Jb2GnKKeMGJB5SGUUrEz3SFVmJASUdZUzy83sLNNQ2gZslg==", + "dev": true, + "license": "MIT", + "dependencies": { + "@jest/core": "^29.7.0", + "@jest/test-result": "^29.7.0", + "@jest/types": "^29.6.3", + "chalk": "^4.0.0", + "create-jest": "^29.7.0", + "exit": "^0.1.2", + "import-local": "^3.0.2", + "jest-config": "^29.7.0", + "jest-util": "^29.7.0", + "jest-validate": "^29.7.0", + "yargs": "^17.3.1" + }, + "bin": { + "jest": "bin/jest.js" + }, + "engines": { + "node": "^14.15.0 || ^16.10.0 || >=18.0.0" + }, + "peerDependencies": { + "node-notifier": "^8.0.1 || ^9.0.0 || ^10.0.0" + }, + "peerDependenciesMeta": { + "node-notifier": { + "optional": true + } + } + }, + "node_modules/jest-config": { + "version": "29.7.0", + "resolved": "https://registry.npmjs.org/jest-config/-/jest-config-29.7.0.tgz", + "integrity": "sha512-uXbpfeQ7R6TZBqI3/TxCU4q4ttk3u0PJeC+E0zbfSoSjq6bJ7buBPxzQPL0ifrkY4DNu4JUdk0ImlBUYi840eQ==", + "dev": true, + "license": "MIT", + "dependencies": { + "@babel/core": "^7.11.6", + "@jest/test-sequencer": "^29.7.0", + "@jest/types": "^29.6.3", + "babel-jest": "^29.7.0", + "chalk": "^4.0.0", + "ci-info": "^3.2.0", + "deepmerge": "^4.2.2", + "glob": "^7.1.3", + "graceful-fs": "^4.2.9", + "jest-circus": "^29.7.0", + "jest-environment-node": "^29.7.0", + "jest-get-type": "^29.6.3", + "jest-regex-util": "^29.6.3", + "jest-resolve": "^29.7.0", + "jest-runner": "^29.7.0", + "jest-util": "^29.7.0", + "jest-validate": "^29.7.0", + "micromatch": "^4.0.4", + "parse-json": "^5.2.0", + "pretty-format": "^29.7.0", + "slash": "^3.0.0", + "strip-json-comments": "^3.1.1" + }, + "engines": { + "node": "^14.15.0 || ^16.10.0 || >=18.0.0" + }, + "peerDependencies": { + "@types/node": "*", + "ts-node": ">=9.0.0" + }, + "peerDependenciesMeta": { + "@types/node": { + "optional": true + }, + "ts-node": { + "optional": true + } + } + }, + "node_modules/jest-diff": { + "version": "29.7.0", + "resolved": "https://registry.npmjs.org/jest-diff/-/jest-diff-29.7.0.tgz", + "integrity": "sha512-LMIgiIrhigmPrs03JHpxUh2yISK3vLFPkAodPeo0+BuF7wA2FoQbkEg1u8gBYBThncu7e1oEDUfIXVuTqLRUjw==", + "dev": true, + "license": "MIT", + "dependencies": { + "chalk": "^4.0.0", + "diff-sequences": "^29.6.3", + "jest-get-type": "^29.6.3", + "pretty-format": "^29.7.0" + }, + "engines": { + "node": "^14.15.0 || ^16.10.0 || >=18.0.0" + } + }, + "node_modules/jest-docblock": { + "version": "29.7.0", + "resolved": "https://registry.npmjs.org/jest-docblock/-/jest-docblock-29.7.0.tgz", + "integrity": "sha512-q617Auw3A612guyaFgsbFeYpNP5t2aoUNLwBUbc/0kD1R4t9ixDbyFTHd1nok4epoVFpr7PmeWHrhvuV3XaJ4g==", + "dev": true, + "license": "MIT", + "dependencies": { + "detect-newline": "^3.0.0" + }, + "engines": { + "node": "^14.15.0 || ^16.10.0 || >=18.0.0" + } + }, + "node_modules/jest-each": { + "version": "29.7.0", + "resolved": "https://registry.npmjs.org/jest-each/-/jest-each-29.7.0.tgz", + "integrity": "sha512-gns+Er14+ZrEoC5fhOfYCY1LOHHr0TI+rQUHZS8Ttw2l7gl+80eHc/gFf2Ktkw0+SIACDTeWvpFcv3B04VembQ==", + "dev": true, + "license": "MIT", + "dependencies": { + "@jest/types": "^29.6.3", + "chalk": "^4.0.0", + "jest-get-type": "^29.6.3", + "jest-util": "^29.7.0", + "pretty-format": "^29.7.0" + }, + "engines": { + "node": "^14.15.0 || ^16.10.0 || >=18.0.0" + } + }, + "node_modules/jest-environment-node": { + "version": "29.7.0", + "resolved": "https://registry.npmjs.org/jest-environment-node/-/jest-environment-node-29.7.0.tgz", + "integrity": "sha512-DOSwCRqXirTOyheM+4d5YZOrWcdu0LNZ87ewUoywbcb2XR4wKgqiG8vNeYwhjFMbEkfju7wx2GYH0P2gevGvFw==", + "dev": true, + "license": "MIT", + "dependencies": { + "@jest/environment": "^29.7.0", + "@jest/fake-timers": "^29.7.0", + "@jest/types": "^29.6.3", + "@types/node": "*", + "jest-mock": "^29.7.0", + "jest-util": "^29.7.0" + }, + "engines": { + "node": "^14.15.0 || ^16.10.0 || >=18.0.0" + } + }, + "node_modules/jest-get-type": { + "version": "29.6.3", + "resolved": "https://registry.npmjs.org/jest-get-type/-/jest-get-type-29.6.3.tgz", + "integrity": "sha512-zrteXnqYxfQh7l5FHyL38jL39di8H8rHoecLH3JNxH3BwOrBsNeabdap5e0I23lD4HHI8W5VFBZqG4Eaq5LNcw==", + "dev": true, + "license": "MIT", + "engines": { + "node": "^14.15.0 || ^16.10.0 || >=18.0.0" + } + }, + "node_modules/jest-haste-map": { + "version": "29.7.0", + "resolved": "https://registry.npmjs.org/jest-haste-map/-/jest-haste-map-29.7.0.tgz", + "integrity": "sha512-fP8u2pyfqx0K1rGn1R9pyE0/KTn+G7PxktWidOBTqFPLYX0b9ksaMFkhK5vrS3DVun09pckLdlx90QthlW7AmA==", + "dev": true, + "license": "MIT", + "dependencies": { + "@jest/types": "^29.6.3", + "@types/graceful-fs": "^4.1.3", + "@types/node": "*", + "anymatch": "^3.0.3", + "fb-watchman": "^2.0.0", + "graceful-fs": "^4.2.9", + "jest-regex-util": "^29.6.3", + "jest-util": "^29.7.0", + "jest-worker": "^29.7.0", + "micromatch": "^4.0.4", + "walker": "^1.0.8" + }, + "engines": { + "node": "^14.15.0 || ^16.10.0 || >=18.0.0" + }, + "optionalDependencies": { + "fsevents": "^2.3.2" + } + }, + "node_modules/jest-leak-detector": { + "version": "29.7.0", + "resolved": "https://registry.npmjs.org/jest-leak-detector/-/jest-leak-detector-29.7.0.tgz", + "integrity": "sha512-kYA8IJcSYtST2BY9I+SMC32nDpBT3J2NvWJx8+JCuCdl/CR1I4EKUJROiP8XtCcxqgTTBGJNdbB1A8XRKbTetw==", + "dev": true, + "license": "MIT", + "dependencies": { + "jest-get-type": "^29.6.3", + "pretty-format": "^29.7.0" + }, + "engines": { + "node": "^14.15.0 || ^16.10.0 || >=18.0.0" + } + }, + "node_modules/jest-matcher-utils": { + "version": "29.7.0", + "resolved": "https://registry.npmjs.org/jest-matcher-utils/-/jest-matcher-utils-29.7.0.tgz", + "integrity": "sha512-sBkD+Xi9DtcChsI3L3u0+N0opgPYnCRPtGcQYrgXmR+hmt/fYfWAL0xRXYU8eWOdfuLgBe0YCW3AFtnRLagq/g==", + "dev": true, + "license": "MIT", + "dependencies": { + "chalk": "^4.0.0", + "jest-diff": "^29.7.0", + "jest-get-type": "^29.6.3", + "pretty-format": "^29.7.0" + }, + "engines": { + "node": "^14.15.0 || ^16.10.0 || >=18.0.0" + } + }, + "node_modules/jest-message-util": { + "version": "29.7.0", + "resolved": "https://registry.npmjs.org/jest-message-util/-/jest-message-util-29.7.0.tgz", + "integrity": "sha512-GBEV4GRADeP+qtB2+6u61stea8mGcOT4mCtrYISZwfu9/ISHFJ/5zOMXYbpBE9RsS5+Gb63DW4FgmnKJ79Kf6w==", + "dev": true, + "license": "MIT", + "dependencies": { + "@babel/code-frame": "^7.12.13", + "@jest/types": "^29.6.3", + "@types/stack-utils": "^2.0.0", + "chalk": "^4.0.0", + "graceful-fs": "^4.2.9", + "micromatch": "^4.0.4", + "pretty-format": "^29.7.0", + "slash": "^3.0.0", + "stack-utils": "^2.0.3" + }, + "engines": { + "node": "^14.15.0 || ^16.10.0 || >=18.0.0" + } + }, + "node_modules/jest-mock": { + "version": "29.7.0", + "resolved": "https://registry.npmjs.org/jest-mock/-/jest-mock-29.7.0.tgz", + "integrity": "sha512-ITOMZn+UkYS4ZFh83xYAOzWStloNzJFO2s8DWrE4lhtGD+AorgnbkiKERe4wQVBydIGPx059g6riW5Btp6Llnw==", + "dev": true, + "license": "MIT", + "dependencies": { + "@jest/types": "^29.6.3", + "@types/node": "*", + "jest-util": "^29.7.0" + }, + "engines": { + "node": "^14.15.0 || ^16.10.0 || >=18.0.0" + } + }, + "node_modules/jest-pnp-resolver": { + "version": "1.2.3", + "resolved": "https://registry.npmjs.org/jest-pnp-resolver/-/jest-pnp-resolver-1.2.3.tgz", + "integrity": "sha512-+3NpwQEnRoIBtx4fyhblQDPgJI0H1IEIkX7ShLUjPGA7TtUTvI1oiKi3SR4oBR0hQhQR80l4WAe5RrXBwWMA8w==", + "dev": true, + "license": "MIT", + "engines": { + "node": ">=6" + }, + "peerDependencies": { + "jest-resolve": "*" + }, + "peerDependenciesMeta": { + "jest-resolve": { + "optional": true + } + } + }, + "node_modules/jest-regex-util": { + "version": "29.6.3", + "resolved": "https://registry.npmjs.org/jest-regex-util/-/jest-regex-util-29.6.3.tgz", + "integrity": "sha512-KJJBsRCyyLNWCNBOvZyRDnAIfUiRJ8v+hOBQYGn8gDyF3UegwiP4gwRR3/SDa42g1YbVycTidUF3rKjyLFDWbg==", + "dev": true, + "license": "MIT", + "engines": { + "node": "^14.15.0 || ^16.10.0 || >=18.0.0" + } + }, + "node_modules/jest-resolve": { + "version": "29.7.0", + "resolved": "https://registry.npmjs.org/jest-resolve/-/jest-resolve-29.7.0.tgz", + "integrity": "sha512-IOVhZSrg+UvVAshDSDtHyFCCBUl/Q3AAJv8iZ6ZjnZ74xzvwuzLXid9IIIPgTnY62SJjfuupMKZsZQRsCvxEgA==", + "dev": true, + "license": "MIT", + "dependencies": { + "chalk": "^4.0.0", + "graceful-fs": "^4.2.9", + "jest-haste-map": "^29.7.0", + "jest-pnp-resolver": "^1.2.2", + "jest-util": "^29.7.0", + "jest-validate": "^29.7.0", + "resolve": "^1.20.0", + "resolve.exports": "^2.0.0", + "slash": "^3.0.0" + }, + "engines": { + "node": "^14.15.0 || ^16.10.0 || >=18.0.0" + } + }, + "node_modules/jest-resolve-dependencies": { + "version": "29.7.0", + "resolved": "https://registry.npmjs.org/jest-resolve-dependencies/-/jest-resolve-dependencies-29.7.0.tgz", + "integrity": "sha512-un0zD/6qxJ+S0et7WxeI3H5XSe9lTBBR7bOHCHXkKR6luG5mwDDlIzVQ0V5cZCuoTgEdcdwzTghYkTWfubi+nA==", + "dev": true, + "license": "MIT", + "dependencies": { + "jest-regex-util": "^29.6.3", + "jest-snapshot": "^29.7.0" + }, + "engines": { + "node": "^14.15.0 || ^16.10.0 || >=18.0.0" + } + }, + "node_modules/jest-runner": { + "version": "29.7.0", + "resolved": "https://registry.npmjs.org/jest-runner/-/jest-runner-29.7.0.tgz", + "integrity": "sha512-fsc4N6cPCAahybGBfTRcq5wFR6fpLznMg47sY5aDpsoejOcVYFb07AHuSnR0liMcPTgBsA3ZJL6kFOjPdoNipQ==", + "dev": true, + "license": "MIT", + "dependencies": { + "@jest/console": "^29.7.0", + "@jest/environment": "^29.7.0", + "@jest/test-result": "^29.7.0", + "@jest/transform": "^29.7.0", + "@jest/types": "^29.6.3", + "@types/node": "*", + "chalk": "^4.0.0", + "emittery": "^0.13.1", + "graceful-fs": "^4.2.9", + "jest-docblock": "^29.7.0", + "jest-environment-node": "^29.7.0", + "jest-haste-map": "^29.7.0", + "jest-leak-detector": "^29.7.0", + "jest-message-util": "^29.7.0", + "jest-resolve": "^29.7.0", + "jest-runtime": "^29.7.0", + "jest-util": "^29.7.0", + "jest-watcher": "^29.7.0", + "jest-worker": "^29.7.0", + "p-limit": "^3.1.0", + "source-map-support": "0.5.13" + }, + "engines": { + "node": "^14.15.0 || ^16.10.0 || >=18.0.0" + } + }, + "node_modules/jest-runtime": { + "version": "29.7.0", + "resolved": "https://registry.npmjs.org/jest-runtime/-/jest-runtime-29.7.0.tgz", + "integrity": "sha512-gUnLjgwdGqW7B4LvOIkbKs9WGbn+QLqRQQ9juC6HndeDiezIwhDP+mhMwHWCEcfQ5RUXa6OPnFF8BJh5xegwwQ==", + "dev": true, + "license": "MIT", + "dependencies": { + "@jest/environment": "^29.7.0", + "@jest/fake-timers": "^29.7.0", + "@jest/globals": "^29.7.0", + "@jest/source-map": "^29.6.3", + "@jest/test-result": "^29.7.0", + "@jest/transform": "^29.7.0", + "@jest/types": "^29.6.3", + "@types/node": "*", + "chalk": "^4.0.0", + "cjs-module-lexer": "^1.0.0", + "collect-v8-coverage": "^1.0.0", + "glob": "^7.1.3", + "graceful-fs": "^4.2.9", + "jest-haste-map": "^29.7.0", + "jest-message-util": "^29.7.0", + "jest-mock": "^29.7.0", + "jest-regex-util": "^29.6.3", + "jest-resolve": "^29.7.0", + "jest-snapshot": "^29.7.0", + "jest-util": "^29.7.0", + "slash": "^3.0.0", + "strip-bom": "^4.0.0" + }, + "engines": { + "node": "^14.15.0 || ^16.10.0 || >=18.0.0" + } + }, + "node_modules/jest-snapshot": { + "version": "29.7.0", + "resolved": "https://registry.npmjs.org/jest-snapshot/-/jest-snapshot-29.7.0.tgz", + "integrity": "sha512-Rm0BMWtxBcioHr1/OX5YCP8Uov4riHvKPknOGs804Zg9JGZgmIBkbtlxJC/7Z4msKYVbIJtfU+tKb8xlYNfdkw==", + "dev": true, + "license": "MIT", + "dependencies": { + "@babel/core": "^7.11.6", + "@babel/generator": "^7.7.2", + "@babel/plugin-syntax-jsx": "^7.7.2", + "@babel/plugin-syntax-typescript": "^7.7.2", + "@babel/types": "^7.3.3", + "@jest/expect-utils": "^29.7.0", + "@jest/transform": "^29.7.0", + "@jest/types": "^29.6.3", + "babel-preset-current-node-syntax": "^1.0.0", + "chalk": "^4.0.0", + "expect": "^29.7.0", + "graceful-fs": "^4.2.9", + "jest-diff": "^29.7.0", + "jest-get-type": "^29.6.3", + "jest-matcher-utils": "^29.7.0", + "jest-message-util": "^29.7.0", + "jest-util": "^29.7.0", + "natural-compare": "^1.4.0", + "pretty-format": "^29.7.0", + "semver": "^7.5.3" + }, + "engines": { + "node": "^14.15.0 || ^16.10.0 || >=18.0.0" + } + }, + "node_modules/jest-snapshot/node_modules/semver": { + "version": "7.7.1", + "resolved": "https://registry.npmjs.org/semver/-/semver-7.7.1.tgz", + "integrity": "sha512-hlq8tAfn0m/61p4BVRcPzIGr6LKiMwo4VM6dGi6pt4qcRkmNzTcWq6eCEjEh+qXjkMDvPlOFFSGwQjoEa6gyMA==", + "dev": true, + "license": "ISC", + "bin": { + "semver": "bin/semver.js" + }, + "engines": { + "node": ">=10" + } + }, + "node_modules/jest-util": { + "version": "29.7.0", + "resolved": "https://registry.npmjs.org/jest-util/-/jest-util-29.7.0.tgz", + "integrity": "sha512-z6EbKajIpqGKU56y5KBUgy1dt1ihhQJgWzUlZHArA/+X2ad7Cb5iF+AK1EWVL/Bo7Rz9uurpqw6SiBCefUbCGA==", + "dev": true, + "license": "MIT", + "dependencies": { + "@jest/types": "^29.6.3", + "@types/node": "*", + "chalk": "^4.0.0", + "ci-info": "^3.2.0", + "graceful-fs": "^4.2.9", + "picomatch": "^2.2.3" + }, + "engines": { + "node": "^14.15.0 || ^16.10.0 || >=18.0.0" + } + }, + "node_modules/jest-validate": { + "version": "29.7.0", + "resolved": "https://registry.npmjs.org/jest-validate/-/jest-validate-29.7.0.tgz", + "integrity": "sha512-ZB7wHqaRGVw/9hST/OuFUReG7M8vKeq0/J2egIGLdvjHCmYqGARhzXmtgi+gVeZ5uXFF219aOc3Ls2yLg27tkw==", + "dev": true, + "license": "MIT", + "dependencies": { + "@jest/types": "^29.6.3", + "camelcase": "^6.2.0", + "chalk": "^4.0.0", + "jest-get-type": "^29.6.3", + "leven": "^3.1.0", + "pretty-format": "^29.7.0" + }, + "engines": { + "node": "^14.15.0 || ^16.10.0 || >=18.0.0" + } + }, + "node_modules/jest-validate/node_modules/camelcase": { + "version": "6.3.0", + "resolved": "https://registry.npmjs.org/camelcase/-/camelcase-6.3.0.tgz", + "integrity": "sha512-Gmy6FhYlCY7uOElZUSbxo2UCDH8owEk996gkbrpsgGtrJLM3J7jGxl9Ic7Qwwj4ivOE5AWZWRMecDdF7hqGjFA==", + "dev": true, + "license": "MIT", + "engines": { + "node": ">=10" + }, + "funding": { + "url": "https://github.com/sponsors/sindresorhus" + } + }, + "node_modules/jest-watcher": { + "version": "29.7.0", + "resolved": "https://registry.npmjs.org/jest-watcher/-/jest-watcher-29.7.0.tgz", + "integrity": "sha512-49Fg7WXkU3Vl2h6LbLtMQ/HyB6rXSIX7SqvBLQmssRBGN9I0PNvPmAmCWSOY6SOvrjhI/F7/bGAv9RtnsPA03g==", + "dev": true, + "license": "MIT", + "dependencies": { + "@jest/test-result": "^29.7.0", + "@jest/types": "^29.6.3", + "@types/node": "*", + "ansi-escapes": "^4.2.1", + "chalk": "^4.0.0", + "emittery": "^0.13.1", + "jest-util": "^29.7.0", + "string-length": "^4.0.1" + }, + "engines": { + "node": "^14.15.0 || ^16.10.0 || >=18.0.0" + } + }, + "node_modules/jest-worker": { + "version": "29.7.0", + "resolved": "https://registry.npmjs.org/jest-worker/-/jest-worker-29.7.0.tgz", + "integrity": "sha512-eIz2msL/EzL9UFTFFx7jBTkeZfku0yUAyZZZmJ93H2TYEiroIx2PQjEXcwYtYl8zXCxb+PAmA2hLIt/6ZEkPHw==", + "dev": true, + "license": "MIT", + "dependencies": { + "@types/node": "*", + "jest-util": "^29.7.0", + "merge-stream": "^2.0.0", + "supports-color": "^8.0.0" + }, + "engines": { + "node": "^14.15.0 || ^16.10.0 || >=18.0.0" + } + }, + "node_modules/jest-worker/node_modules/supports-color": { + "version": "8.1.1", + "resolved": "https://registry.npmjs.org/supports-color/-/supports-color-8.1.1.tgz", + "integrity": "sha512-MpUEN2OodtUzxvKQl72cUF7RQ5EiHsGvSsVG0ia9c5RbWGL2CI4C7EpPS8UTBIplnlzZiNuV56w+FuNxy3ty2Q==", + "dev": true, + "license": "MIT", + "dependencies": { + "has-flag": "^4.0.0" + }, + "engines": { + "node": ">=10" + }, + "funding": { + "url": "https://github.com/chalk/supports-color?sponsor=1" + } + }, + "node_modules/js-tokens": { + "version": "4.0.0", + "resolved": "https://registry.npmjs.org/js-tokens/-/js-tokens-4.0.0.tgz", + "integrity": "sha512-RdJUflcE3cUzKiMqQgsCu06FPu9UdIJO0beYbPhHN4k6apgJtifcoCtT9bcxOpYBtpD2kCM6Sbzg4CausW/PKQ==", + "dev": true, + "license": "MIT" + }, + "node_modules/js-yaml": { + "version": "3.14.1", + "resolved": "https://registry.npmjs.org/js-yaml/-/js-yaml-3.14.1.tgz", + "integrity": "sha512-okMH7OXXJ7YrN9Ok3/SXrnu4iX9yOk+25nqX4imS2npuvTYDmo/QEZoqwZkYaIDk3jVvBOTOIEgEhaLOynBS9g==", + "dev": true, + "license": "MIT", + "dependencies": { + "argparse": "^1.0.7", + "esprima": "^4.0.0" + }, + "bin": { + "js-yaml": "bin/js-yaml.js" + } + }, + "node_modules/jsesc": { + "version": "3.1.0", + "resolved": "https://registry.npmjs.org/jsesc/-/jsesc-3.1.0.tgz", + "integrity": "sha512-/sM3dO2FOzXjKQhJuo0Q173wf2KOo8t4I8vHy6lF9poUp7bKT0/NHE8fPX23PwfhnykfqnC2xRxOnVw5XuGIaA==", + "dev": true, + "license": "MIT", + "bin": { + "jsesc": "bin/jsesc" + }, + "engines": { + "node": ">=6" + } + }, + "node_modules/json-buffer": { + "version": "3.0.1", + "resolved": "https://registry.npmjs.org/json-buffer/-/json-buffer-3.0.1.tgz", + "integrity": "sha512-4bV5BfR2mqfQTJm+V5tPPdf+ZpuhiIvTuAB5g8kcrXOZpTT/QwwVRWBywX1ozr6lEuPdbHxwaJlm9G6mI2sfSQ==", + "dev": true, + "license": "MIT" + }, + "node_modules/json-parse-better-errors": { + "version": "1.0.2", + "resolved": "https://registry.npmjs.org/json-parse-better-errors/-/json-parse-better-errors-1.0.2.tgz", + "integrity": "sha512-mrqyZKfX5EhL7hvqcV6WG1yYjnjeuYDzDhhcAAUrq8Po85NBQBJP+ZDUT75qZQ98IkUoBqdkExkukOU7Ts2wrw==", + "dev": true, + "license": "MIT" + }, + "node_modules/json-parse-even-better-errors": { + "version": "2.3.1", + "resolved": "https://registry.npmjs.org/json-parse-even-better-errors/-/json-parse-even-better-errors-2.3.1.tgz", + "integrity": "sha512-xyFwyhro/JEof6Ghe2iz2NcXoj2sloNsWr/XsERDK/oiPCfaNhl5ONfp+jQdAZRQQ0IJWNzH9zIZF7li91kh2w==", + "dev": true, + "license": "MIT" + }, + "node_modules/json-schema-traverse": { + "version": "0.4.1", + "resolved": "https://registry.npmjs.org/json-schema-traverse/-/json-schema-traverse-0.4.1.tgz", + "integrity": "sha512-xbbCH5dCYU5T8LcEhhuh7HJ88HXuW3qsI3Y0zOZFKfZEHcpWiHU/Jxzk629Brsab/mMiHQti9wMP+845RPe3Vg==", + "dev": true, + "license": "MIT" + }, + "node_modules/json-stable-stringify-without-jsonify": { + "version": "1.0.1", + "resolved": "https://registry.npmjs.org/json-stable-stringify-without-jsonify/-/json-stable-stringify-without-jsonify-1.0.1.tgz", + "integrity": "sha512-Bdboy+l7tA3OGW6FjyFHWkP5LuByj1Tk33Ljyq0axyzdk9//JSi2u3fP1QSmd1KNwq6VOKYGlAu87CisVir6Pw==", + "dev": true, + "license": "MIT" + }, + "node_modules/json5": { + "version": "2.2.3", + "resolved": "https://registry.npmjs.org/json5/-/json5-2.2.3.tgz", + "integrity": "sha512-XmOWe7eyHYH14cLdVPoyg+GOH3rYX++KpzrylJwSW98t3Nk+U8XOl8FWKOgwtzdb8lXGf6zYwDUzeHMWfxasyg==", + "dev": true, + "license": "MIT", + "bin": { + "json5": "lib/cli.js" + }, + "engines": { + "node": ">=6" + } + }, + "node_modules/jsonschema": { + "version": "1.5.0", + "resolved": "https://registry.npmjs.org/jsonschema/-/jsonschema-1.5.0.tgz", + "integrity": "sha512-K+A9hhqbn0f3pJX17Q/7H6yQfD/5OXgdrR5UE12gMXCiN9D5Xq2o5mddV2QEcX/bjla99ASsAAQUyMCCRWAEhw==", + "license": "MIT", + "engines": { + "node": "*" + } + }, + "node_modules/jszip": { + "version": "3.10.1", + "resolved": "https://registry.npmjs.org/jszip/-/jszip-3.10.1.tgz", + "integrity": "sha512-xXDvecyTpGLrqFrvkrUSoxxfJI5AH7U8zxxtVclpsUtMCq4JQ290LY8AW5c7Ggnr/Y/oK+bQMbqK2qmtk3pN4g==", + "license": "(MIT OR GPL-3.0-or-later)", + "dependencies": { + "lie": "~3.3.0", + "pako": "~1.0.2", + "readable-stream": "~2.3.6", + "setimmediate": "^1.0.5" + } + }, + "node_modules/jszip/node_modules/isarray": { + "version": "1.0.0", + "resolved": "https://registry.npmjs.org/isarray/-/isarray-1.0.0.tgz", + "integrity": "sha512-VLghIWNM6ELQzo7zwmcg0NmTVyWKYjvIeM83yjp0wRDTmUnrM678fQbcKBo6n2CJEF0szoG//ytg+TKla89ALQ==", + "license": "MIT" + }, + "node_modules/jszip/node_modules/readable-stream": { + "version": "2.3.8", + "resolved": "https://registry.npmjs.org/readable-stream/-/readable-stream-2.3.8.tgz", + "integrity": "sha512-8p0AUk4XODgIewSi0l8Epjs+EVnWiK7NoDIEGU0HhE7+ZyY8D1IMY7odu5lRrFXGg71L15KG8QrPmum45RTtdA==", + "license": "MIT", + "dependencies": { + "core-util-is": "~1.0.0", + "inherits": "~2.0.3", + "isarray": "~1.0.0", + "process-nextick-args": "~2.0.0", + "safe-buffer": "~5.1.1", + "string_decoder": "~1.1.1", + "util-deprecate": "~1.0.1" + } + }, + "node_modules/jszip/node_modules/safe-buffer": { + "version": "5.1.2", + "resolved": "https://registry.npmjs.org/safe-buffer/-/safe-buffer-5.1.2.tgz", + "integrity": "sha512-Gd2UZBJDkXlY7GbJxfsE8/nvKkUEU1G38c1siN6QP6a9PT9MmHB8GnpscSmMJSoF8LOIrt8ud/wPtojys4G6+g==", + "license": "MIT" + }, + "node_modules/jszip/node_modules/string_decoder": { + "version": "1.1.1", + "resolved": "https://registry.npmjs.org/string_decoder/-/string_decoder-1.1.1.tgz", + "integrity": "sha512-n/ShnvDi6FHbbVfviro+WojiFzv+s8MPMHBczVePfUpDJLwoLT0ht1l4YwBCbi8pJAveEEdnkHyPyTP/mzRfwg==", + "license": "MIT", + "dependencies": { + "safe-buffer": "~5.1.0" + } + }, + "node_modules/keyv": { + "version": "4.5.4", + "resolved": "https://registry.npmjs.org/keyv/-/keyv-4.5.4.tgz", + "integrity": "sha512-oxVHkHR/EJf2CNXnWxRLW6mg7JyCCUcG0DtEGmL2ctUo1PNTin1PUil+r/+4r5MpVgC/fn1kjsx7mjSujKqIpw==", + "dev": true, + "license": "MIT", + "dependencies": { + "json-buffer": "3.0.1" + } + }, + "node_modules/kleur": { + "version": "3.0.3", + "resolved": "https://registry.npmjs.org/kleur/-/kleur-3.0.3.tgz", + "integrity": "sha512-eTIzlVOSUR+JxdDFepEYcBMtZ9Qqdef+rnzWdRZuMbOywu5tO2w2N7rqjoANZ5k9vywhL6Br1VRjUIgTQx4E8w==", + "dev": true, + "license": "MIT", + "engines": { + "node": ">=6" + } + }, + "node_modules/leven": { + "version": "3.1.0", + "resolved": "https://registry.npmjs.org/leven/-/leven-3.1.0.tgz", + "integrity": "sha512-qsda+H8jTaUaN/x5vzW2rzc+8Rw4TAQ/4KjB46IwK5VH+IlVeeeje/EoZRpiXvIqjFgK84QffqPztGI3VBLG1A==", + "dev": true, + "license": "MIT", + "engines": { + "node": ">=6" + } + }, + "node_modules/levn": { + "version": "0.4.1", + "resolved": "https://registry.npmjs.org/levn/-/levn-0.4.1.tgz", + "integrity": "sha512-+bT2uH4E5LGE7h/n3evcS/sQlJXCpIp6ym8OWJ5eV6+67Dsql/LaaT7qJBAt2rzfoa/5QBGBhxDix1dMt2kQKQ==", + "dev": true, + "license": "MIT", + "dependencies": { + "prelude-ls": "^1.2.1", + "type-check": "~0.4.0" + }, + "engines": { + "node": ">= 0.8.0" + } + }, + "node_modules/lie": { + "version": "3.3.0", + "resolved": "https://registry.npmjs.org/lie/-/lie-3.3.0.tgz", + "integrity": "sha512-UaiMJzeWRlEujzAuw5LokY1L5ecNQYZKfmyZ9L7wDHb/p5etKaxXhohBcrw0EYby+G/NA52vRSN4N39dxHAIwQ==", + "license": "MIT", + "dependencies": { + "immediate": "~3.0.5" + } + }, + "node_modules/lines-and-columns": { + "version": "1.2.4", + "resolved": "https://registry.npmjs.org/lines-and-columns/-/lines-and-columns-1.2.4.tgz", + "integrity": "sha512-7ylylesZQ/PV29jhEDl3Ufjo6ZX7gCqJr5F7PKrqc93v7fzSymt1BpwEU8nAUXs8qzzvqhbjhK5QZg6Mt/HkBg==", + "dev": true, + "license": "MIT" + }, + "node_modules/load-json-file": { + "version": "4.0.0", + "resolved": "https://registry.npmjs.org/load-json-file/-/load-json-file-4.0.0.tgz", + "integrity": "sha512-Kx8hMakjX03tiGTLAIdJ+lL0htKnXjEZN6hk/tozf/WOuYGdZBJrZ+rCJRbVCugsjB3jMLn9746NsQIf5VjBMw==", + "dev": true, + "license": "MIT", + "dependencies": { + "graceful-fs": "^4.1.2", + "parse-json": "^4.0.0", + "pify": "^3.0.0", + "strip-bom": "^3.0.0" + }, + "engines": { + "node": ">=4" + } + }, + "node_modules/load-json-file/node_modules/parse-json": { + "version": "4.0.0", + "resolved": "https://registry.npmjs.org/parse-json/-/parse-json-4.0.0.tgz", + "integrity": "sha512-aOIos8bujGN93/8Ox/jPLh7RwVnPEysynVFE+fQZyg6jKELEHwzgKdLRFHUgXJL6kylijVSBC4BvN9OmsB48Rw==", + "dev": true, + "license": "MIT", + "dependencies": { + "error-ex": "^1.3.1", + "json-parse-better-errors": "^1.0.1" + }, + "engines": { + "node": ">=4" + } + }, + "node_modules/load-json-file/node_modules/strip-bom": { + "version": "3.0.0", + "resolved": "https://registry.npmjs.org/strip-bom/-/strip-bom-3.0.0.tgz", + "integrity": "sha512-vavAMRXOgBVNF6nyEEmL3DBK19iRpDcoIwW+swQ+CbGiu7lju6t+JklA1MHweoWtadgt4ISVUsXLyDq34ddcwA==", + "dev": true, + "license": "MIT", + "engines": { + "node": ">=4" + } + }, + "node_modules/locate-path": { + "version": "6.0.0", + "resolved": "https://registry.npmjs.org/locate-path/-/locate-path-6.0.0.tgz", + "integrity": "sha512-iPZK6eYjbxRu3uB4/WZ3EsEIMJFMqAoopl3R+zuq0UjcAm/MO6KCweDgPfP3elTztoKP3KtnVHxTn2NHBSDVUw==", + "dev": true, + "license": "MIT", + "dependencies": { + "p-locate": "^5.0.0" + }, + "engines": { + "node": ">=10" + }, + "funding": { + "url": "https://github.com/sponsors/sindresorhus" + } + }, + "node_modules/lodash.merge": { + "version": "4.6.2", + "resolved": "https://registry.npmjs.org/lodash.merge/-/lodash.merge-4.6.2.tgz", + "integrity": "sha512-0KpjqXRVvrYyCsX1swR/XTK0va6VQkQM6MNo7PqW77ByjAhoARA8EfrP1N4+KlKj8YS0ZUCtRT/YUuhyYDujIQ==", + "dev": true, + "license": "MIT" + }, + "node_modules/log-symbols": { + "version": "4.1.0", + "resolved": "https://registry.npmjs.org/log-symbols/-/log-symbols-4.1.0.tgz", + "integrity": "sha512-8XPvpAA8uyhfteu8pIvQxpJZ7SYYdpUivZpGy6sFsBuKRY/7rQGavedeB8aK+Zkyq6upMFVL/9AW6vOYzfRyLg==", + "dev": true, + "license": "MIT", + "dependencies": { + "chalk": "^4.1.0", + "is-unicode-supported": "^0.1.0" + }, + "engines": { + "node": ">=10" + }, + "funding": { + "url": "https://github.com/sponsors/sindresorhus" + } + }, + "node_modules/lowercase-keys": { + "version": "2.0.0", + "resolved": "https://registry.npmjs.org/lowercase-keys/-/lowercase-keys-2.0.0.tgz", + "integrity": "sha512-tqNXrS78oMOE73NMxK4EMLQsQowWf8jKooH9g7xPavRT706R6bkQJ6DY2Te7QukaZsulxa30wQ7bk0pm4XiHmA==", + "dev": true, + "license": "MIT", + "engines": { + "node": ">=8" + } + }, + "node_modules/lru-cache": { + "version": "5.1.1", + "resolved": "https://registry.npmjs.org/lru-cache/-/lru-cache-5.1.1.tgz", + "integrity": "sha512-KpNARQA3Iwv+jTA0utUVVbrh+Jlrr1Fv0e56GGzAFOXN7dk/FviaDW8LHmK52DlcH4WP2n6gI8vN1aesBFgo9w==", + "dev": true, + "license": "ISC", + "dependencies": { + "yallist": "^3.0.2" + } + }, + "node_modules/make-dir": { + "version": "4.0.0", + "resolved": "https://registry.npmjs.org/make-dir/-/make-dir-4.0.0.tgz", + "integrity": "sha512-hXdUTZYIVOt1Ex//jAQi+wTZZpUpwBj/0QsOzqegb3rGMMeJiSEu5xLHnYfBrRV4RH2+OCSOO95Is/7x1WJ4bw==", + "dev": true, + "license": "MIT", + "dependencies": { + "semver": "^7.5.3" + }, + "engines": { + "node": ">=10" + }, + "funding": { + "url": "https://github.com/sponsors/sindresorhus" + } + }, + "node_modules/make-dir/node_modules/semver": { + "version": "7.7.1", + "resolved": "https://registry.npmjs.org/semver/-/semver-7.7.1.tgz", + "integrity": "sha512-hlq8tAfn0m/61p4BVRcPzIGr6LKiMwo4VM6dGi6pt4qcRkmNzTcWq6eCEjEh+qXjkMDvPlOFFSGwQjoEa6gyMA==", + "dev": true, + "license": "ISC", + "bin": { + "semver": "bin/semver.js" + }, + "engines": { + "node": ">=10" + } + }, + "node_modules/makeerror": { + "version": "1.0.12", + "resolved": "https://registry.npmjs.org/makeerror/-/makeerror-1.0.12.tgz", + "integrity": "sha512-JmqCvUhmt43madlpFzG4BQzG2Z3m6tvQDNKdClZnO3VbIudJYmxsT0FNJMeiB2+JTSlTQTSbU8QdesVmwJcmLg==", + "dev": true, + "license": "BSD-3-Clause", + "dependencies": { + "tmpl": "1.0.5" + } + }, + "node_modules/math-intrinsics": { + "version": "1.1.0", + "resolved": "https://registry.npmjs.org/math-intrinsics/-/math-intrinsics-1.1.0.tgz", + "integrity": "sha512-/IXtbwEk5HTPyEwyKX6hGkYXxM9nbj64B+ilVJnC/R6B0pH5G4V3b0pVbL7DBj4tkhBAppbQUlf6F6Xl9LHu1g==", + "license": "MIT", + "engines": { + "node": ">= 0.4" + } + }, + "node_modules/memorystream": { + "version": "0.3.1", + "resolved": "https://registry.npmjs.org/memorystream/-/memorystream-0.3.1.tgz", + "integrity": "sha512-S3UwM3yj5mtUSEfP41UZmt/0SCoVYUcU1rkXv+BQ5Ig8ndL4sPoJNBUJERafdPb5jjHJGuMgytgKvKIf58XNBw==", + "dev": true, + "engines": { + "node": ">= 0.10.0" + } + }, + "node_modules/merge-stream": { + "version": "2.0.0", + "resolved": "https://registry.npmjs.org/merge-stream/-/merge-stream-2.0.0.tgz", + "integrity": "sha512-abv/qOcuPfk3URPfDzmZU1LKmuw8kT+0nIHvKrKgFrwifol/doWcdA4ZqsWQ8ENrFKkd67Mfpo/LovbIUsbt3w==", + "dev": true, + "license": "MIT" + }, + "node_modules/merge2": { + "version": "1.4.1", + "resolved": "https://registry.npmjs.org/merge2/-/merge2-1.4.1.tgz", + "integrity": "sha512-8q7VEgMJW4J8tcfVPy8g09NcQwZdbwFEqhe/WZkoIzjn/3TGDwtOCYtXGxA3O8tPzpczCCDgv+P2P5y00ZJOOg==", + "dev": true, + "license": "MIT", + "engines": { + "node": ">= 8" + } + }, + "node_modules/micromatch": { + "version": "4.0.8", + "resolved": "https://registry.npmjs.org/micromatch/-/micromatch-4.0.8.tgz", + "integrity": "sha512-PXwfBhYu0hBCPw8Dn0E+WDYb7af3dSLVWKi3HGv84IdF4TyFoC0ysxFd0Goxw7nSv4T/PzEJQxsYsEiFCKo2BA==", + "dev": true, + "license": "MIT", + "dependencies": { + "braces": "^3.0.3", + "picomatch": "^2.3.1" + }, + "engines": { + "node": ">=8.6" + } + }, + "node_modules/mime-db": { + "version": "1.52.0", + "resolved": "https://registry.npmjs.org/mime-db/-/mime-db-1.52.0.tgz", + "integrity": "sha512-sPU4uV7dYlvtWJxwwxHD0PuihVNiE7TyAbQ5SWxDCB9mUYvOgroQOwYQQOKPJ8CIbE+1ETVlOoK1UC2nU3gYvg==", + "license": "MIT", + "engines": { + "node": ">= 0.6" + } + }, + "node_modules/mime-types": { + "version": "2.1.35", + "resolved": "https://registry.npmjs.org/mime-types/-/mime-types-2.1.35.tgz", + "integrity": "sha512-ZDY+bPm5zTTF+YpCrAU9nK0UgICYPT0QtT1NZWFv4s++TNkcgVaT0g6+4R2uI4MjQjzysHB1zxuWL50hzaeXiw==", + "license": "MIT", + "dependencies": { + "mime-db": "1.52.0" + }, + "engines": { + "node": ">= 0.6" + } + }, + "node_modules/mimic-fn": { + "version": "2.1.0", + "resolved": "https://registry.npmjs.org/mimic-fn/-/mimic-fn-2.1.0.tgz", + "integrity": "sha512-OqbOk5oEQeAZ8WXWydlu9HJjz9WVdEIvamMCcXmuqUYjTknH/sqsWvhQ3vgwKFRR1HpjvNBKQ37nbJgYzGqGcg==", + "dev": true, + "license": "MIT", + "engines": { + "node": ">=6" + } + }, + "node_modules/mimic-response": { + "version": "1.0.1", + "resolved": "https://registry.npmjs.org/mimic-response/-/mimic-response-1.0.1.tgz", + "integrity": "sha512-j5EctnkH7amfV/q5Hgmoal1g2QHFJRraOtmx0JpIqkxhBhI/lJSl1nMpQ45hVarwNETOoWEimndZ4QK0RHxuxQ==", + "dev": true, + "license": "MIT", + "engines": { + "node": ">=4" + } + }, + "node_modules/minimatch": { + "version": "3.0.8", + "resolved": "https://registry.npmjs.org/minimatch/-/minimatch-3.0.8.tgz", + "integrity": "sha512-6FsRAQsxQ61mw+qP1ZzbL9Bc78x2p5OqNgNpnoAFLTrX8n5Kxph0CsnhmKKNXTWjXqU5L0pGPR7hYk+XWZr60Q==", + "dev": true, + "license": "ISC", + "dependencies": { + "brace-expansion": "^1.1.7" + }, + "engines": { + "node": "*" + } + }, + "node_modules/minimist": { + "version": "1.2.8", + "resolved": "https://registry.npmjs.org/minimist/-/minimist-1.2.8.tgz", + "integrity": "sha512-2yyAR8qBkN3YuheJanUpWC5U3bb5osDywNB8RzDVlDwDHbocAJveqqj1u8+SVD7jkWT4yvsHCpWqqWqAxb0zCA==", + "dev": true, + "license": "MIT", + "funding": { + "url": "https://github.com/sponsors/ljharb" + } + }, + "node_modules/mock-xmlhttprequest": { + "version": "8.4.1", + "resolved": "https://registry.npmjs.org/mock-xmlhttprequest/-/mock-xmlhttprequest-8.4.1.tgz", + "integrity": "sha512-2ORxRN+h40+3/Ylw9LKOtYGfQIoX6grGQlmbvMKqaeZ5/l7oeMvqdJxyG/ax3Poy7VbqMTADI6BwTmO7u10Wrw==", + "license": "MIT", + "engines": { + "node": ">=16.0.0" + } + }, + "node_modules/ms": { + "version": "2.1.3", + "resolved": "https://registry.npmjs.org/ms/-/ms-2.1.3.tgz", + "integrity": "sha512-6FlzubTLZG3J2a/NVCAleEhjzq5oxgHyaCU9yYXvcLsvoVaHJq/s5xXI6/XXP6tz7R9xAOtHnSO/tXtF3WRTlA==", + "dev": true, + "license": "MIT" + }, + "node_modules/natural-compare": { + "version": "1.4.0", + "resolved": "https://registry.npmjs.org/natural-compare/-/natural-compare-1.4.0.tgz", + "integrity": "sha512-OWND8ei3VtNC9h7V60qff3SVobHr996CTwgxubgyQYEpg290h9J0buyECNNJexkFm5sOajh5G116RYA1c8ZMSw==", + "dev": true, + "license": "MIT" + }, + "node_modules/nice-try": { + "version": "1.0.5", + "resolved": "https://registry.npmjs.org/nice-try/-/nice-try-1.0.5.tgz", + "integrity": "sha512-1nh45deeb5olNY7eX82BkPO7SSxR5SSYJiPTrTdFUVYwAl8CKMA5N9PjTYkHiRjisVcxcQ1HXdLhx2qxxJzLNQ==", + "dev": true, + "license": "MIT" + }, + "node_modules/node-int64": { + "version": "0.4.0", + "resolved": "https://registry.npmjs.org/node-int64/-/node-int64-0.4.0.tgz", + "integrity": "sha512-O5lz91xSOeoXP6DulyHfllpq+Eg00MWitZIbtPfoSEvqIHdl5gfcY6hYzDWnj0qD5tz52PI08u9qUvSVeUBeHw==", + "dev": true, + "license": "MIT" + }, + "node_modules/node-releases": { + "version": "2.0.19", + "resolved": "https://registry.npmjs.org/node-releases/-/node-releases-2.0.19.tgz", + "integrity": "sha512-xxOWJsBKtzAq7DY0J+DTzuz58K8e7sJbdgwkbMWQe8UYB6ekmsQ45q0M/tJDsGaZmbC+l7n57UV8Hl5tHxO9uw==", + "dev": true, + "license": "MIT" + }, + "node_modules/normalize-package-data": { + "version": "2.5.0", + "resolved": "https://registry.npmjs.org/normalize-package-data/-/normalize-package-data-2.5.0.tgz", + "integrity": "sha512-/5CMN3T0R4XTj4DcGaexo+roZSdSFW/0AOOTROrjxzCG1wrWXEsGbRKevjlIL+ZDE4sZlJr5ED4YW0yqmkK+eA==", + "dev": true, + "license": "BSD-2-Clause", + "dependencies": { + "hosted-git-info": "^2.1.4", + "resolve": "^1.10.0", + "semver": "2 || 3 || 4 || 5", + "validate-npm-package-license": "^3.0.1" + } + }, + "node_modules/normalize-package-data/node_modules/semver": { + "version": "5.7.2", + "resolved": "https://registry.npmjs.org/semver/-/semver-5.7.2.tgz", + "integrity": "sha512-cBznnQ9KjJqU67B52RMC65CMarK2600WFnbkcaiwWq3xy/5haFJlshgnpjovMVJ+Hff49d8GEn0b87C5pDQ10g==", + "dev": true, + "license": "ISC", + "bin": { + "semver": "bin/semver" + } + }, + "node_modules/normalize-path": { + "version": "3.0.0", + "resolved": "https://registry.npmjs.org/normalize-path/-/normalize-path-3.0.0.tgz", + "integrity": "sha512-6eZs5Ls3WtCisHWp9S2GUy8dqkpGi4BVSz3GaqiE6ezub0512ESztXUwUB6C6IKbQkY2Pnb/mD4WYojCRwcwLA==", + "dev": true, + "license": "MIT", + "engines": { + "node": ">=0.10.0" + } + }, + "node_modules/normalize-url": { + "version": "6.1.0", + "resolved": "https://registry.npmjs.org/normalize-url/-/normalize-url-6.1.0.tgz", + "integrity": "sha512-DlL+XwOy3NxAQ8xuC0okPgK46iuVNAK01YN7RueYBqqFeGsBjV9XmCAzAdgt+667bCl5kPh9EqKKDwnaPG1I7A==", + "dev": true, + "license": "MIT", + "engines": { + "node": ">=10" + }, + "funding": { + "url": "https://github.com/sponsors/sindresorhus" + } + }, + "node_modules/npm-run-all": { + "version": "4.1.5", + "resolved": "https://registry.npmjs.org/npm-run-all/-/npm-run-all-4.1.5.tgz", + "integrity": "sha512-Oo82gJDAVcaMdi3nuoKFavkIHBRVqQ1qvMb+9LHk/cF4P6B2m8aP04hGf7oL6wZ9BuGwX1onlLhpuoofSyoQDQ==", + "dev": true, + "license": "MIT", + "dependencies": { + "ansi-styles": "^3.2.1", + "chalk": "^2.4.1", + "cross-spawn": "^6.0.5", + "memorystream": "^0.3.1", + "minimatch": "^3.0.4", + "pidtree": "^0.3.0", + "read-pkg": "^3.0.0", + "shell-quote": "^1.6.1", + "string.prototype.padend": "^3.0.0" + }, + "bin": { + "npm-run-all": "bin/npm-run-all/index.js", + "run-p": "bin/run-p/index.js", + "run-s": "bin/run-s/index.js" + }, + "engines": { + "node": ">= 4" + } + }, + "node_modules/npm-run-all/node_modules/ansi-styles": { + "version": "3.2.1", + "resolved": "https://registry.npmjs.org/ansi-styles/-/ansi-styles-3.2.1.tgz", + "integrity": "sha512-VT0ZI6kZRdTh8YyJw3SMbYm/u+NqfsAxEpWO0Pf9sq8/e94WxxOpPKx9FR1FlyCtOVDNOQ+8ntlqFxiRc+r5qA==", + "dev": true, + "license": "MIT", + "dependencies": { + "color-convert": "^1.9.0" + }, + "engines": { + "node": ">=4" + } + }, + "node_modules/npm-run-all/node_modules/chalk": { + "version": "2.4.2", + "resolved": "https://registry.npmjs.org/chalk/-/chalk-2.4.2.tgz", + "integrity": "sha512-Mti+f9lpJNcwF4tWV8/OrTTtF1gZi+f8FqlyAdouralcFWFQWF2+NgCHShjkCb+IFBLq9buZwE1xckQU4peSuQ==", + "dev": true, + "license": "MIT", + "dependencies": { + "ansi-styles": "^3.2.1", + "escape-string-regexp": "^1.0.5", + "supports-color": "^5.3.0" + }, + "engines": { + "node": ">=4" + } + }, + "node_modules/npm-run-all/node_modules/color-convert": { + "version": "1.9.3", + "resolved": "https://registry.npmjs.org/color-convert/-/color-convert-1.9.3.tgz", + "integrity": "sha512-QfAUtd+vFdAtFQcC8CCyYt1fYWxSqAiK2cSD6zDB8N3cpsEBAvRxp9zOGg6G/SHHJYAT88/az/IuDGALsNVbGg==", + "dev": true, + "license": "MIT", + "dependencies": { + "color-name": "1.1.3" + } + }, + "node_modules/npm-run-all/node_modules/color-name": { + "version": "1.1.3", + "resolved": "https://registry.npmjs.org/color-name/-/color-name-1.1.3.tgz", + "integrity": "sha512-72fSenhMw2HZMTVHeCA9KCmpEIbzWiQsjN+BHcBbS9vr1mtt+vJjPdksIBNUmKAW8TFUDPJK5SUU3QhE9NEXDw==", + "dev": true, + "license": "MIT" + }, + "node_modules/npm-run-all/node_modules/cross-spawn": { + "version": "6.0.6", + "resolved": "https://registry.npmjs.org/cross-spawn/-/cross-spawn-6.0.6.tgz", + "integrity": "sha512-VqCUuhcd1iB+dsv8gxPttb5iZh/D0iubSP21g36KXdEuf6I5JiioesUVjpCdHV9MZRUfVFlvwtIUyPfxo5trtw==", + "dev": true, + "license": "MIT", + "dependencies": { + "nice-try": "^1.0.4", + "path-key": "^2.0.1", + "semver": "^5.5.0", + "shebang-command": "^1.2.0", + "which": "^1.2.9" + }, + "engines": { + "node": ">=4.8" + } + }, + "node_modules/npm-run-all/node_modules/escape-string-regexp": { + "version": "1.0.5", + "resolved": "https://registry.npmjs.org/escape-string-regexp/-/escape-string-regexp-1.0.5.tgz", + "integrity": "sha512-vbRorB5FUQWvla16U8R/qgaFIya2qGzwDrNmCZuYKrbdSUMG6I1ZCGQRefkRVhuOkIGVne7BQ35DSfo1qvJqFg==", + "dev": true, + "license": "MIT", + "engines": { + "node": ">=0.8.0" + } + }, + "node_modules/npm-run-all/node_modules/has-flag": { + "version": "3.0.0", + "resolved": "https://registry.npmjs.org/has-flag/-/has-flag-3.0.0.tgz", + "integrity": "sha512-sKJf1+ceQBr4SMkvQnBDNDtf4TXpVhVGateu0t918bl30FnbE2m4vNLX+VWe/dpjlb+HugGYzW7uQXH98HPEYw==", + "dev": true, + "license": "MIT", + "engines": { + "node": ">=4" + } + }, + "node_modules/npm-run-all/node_modules/isexe": { + "version": "2.0.0", + "resolved": "https://registry.npmjs.org/isexe/-/isexe-2.0.0.tgz", + "integrity": "sha512-RHxMLp9lnKHGHRng9QFhRCMbYAcVpn69smSGcq3f36xjgVVWThj4qqLbTLlq7Ssj8B+fIQ1EuCEGI2lKsyQeIw==", + "dev": true, + "license": "ISC" + }, + "node_modules/npm-run-all/node_modules/path-key": { + "version": "2.0.1", + "resolved": "https://registry.npmjs.org/path-key/-/path-key-2.0.1.tgz", + "integrity": "sha512-fEHGKCSmUSDPv4uoj8AlD+joPlq3peND+HRYyxFz4KPw4z926S/b8rIuFs2FYJg3BwsxJf6A9/3eIdLaYC+9Dw==", + "dev": true, + "license": "MIT", + "engines": { + "node": ">=4" + } + }, + "node_modules/npm-run-all/node_modules/semver": { + "version": "5.7.2", + "resolved": "https://registry.npmjs.org/semver/-/semver-5.7.2.tgz", + "integrity": "sha512-cBznnQ9KjJqU67B52RMC65CMarK2600WFnbkcaiwWq3xy/5haFJlshgnpjovMVJ+Hff49d8GEn0b87C5pDQ10g==", + "dev": true, + "license": "ISC", + "bin": { + "semver": "bin/semver" + } + }, + "node_modules/npm-run-all/node_modules/shebang-command": { + "version": "1.2.0", + "resolved": "https://registry.npmjs.org/shebang-command/-/shebang-command-1.2.0.tgz", + "integrity": "sha512-EV3L1+UQWGor21OmnvojK36mhg+TyIKDh3iFBKBohr5xeXIhNBcx8oWdgkTEEQ+BEFFYdLRuqMfd5L84N1V5Vg==", + "dev": true, + "license": "MIT", + "dependencies": { + "shebang-regex": "^1.0.0" + }, + "engines": { + "node": ">=0.10.0" + } + }, + "node_modules/npm-run-all/node_modules/shebang-regex": { + "version": "1.0.0", + "resolved": "https://registry.npmjs.org/shebang-regex/-/shebang-regex-1.0.0.tgz", + "integrity": "sha512-wpoSFAxys6b2a2wHZ1XpDSgD7N9iVjg29Ph9uV/uaP9Ex/KXlkTZTeddxDPSYQpgvzKLGJke2UU0AzoGCjNIvQ==", + "dev": true, + "license": "MIT", + "engines": { + "node": ">=0.10.0" + } + }, + "node_modules/npm-run-all/node_modules/supports-color": { + "version": "5.5.0", + "resolved": "https://registry.npmjs.org/supports-color/-/supports-color-5.5.0.tgz", + "integrity": "sha512-QjVjwdXIt408MIiAqCX4oUKsgU2EqAGzs2Ppkm4aQYbjm+ZEWEcW4SfFNTr4uMNZma0ey4f5lgLrkB0aX0QMow==", + "dev": true, + "license": "MIT", + "dependencies": { + "has-flag": "^3.0.0" + }, + "engines": { + "node": ">=4" + } + }, + "node_modules/npm-run-all/node_modules/which": { + "version": "1.3.1", + "resolved": "https://registry.npmjs.org/which/-/which-1.3.1.tgz", + "integrity": "sha512-HxJdYWq1MTIQbJ3nw0cqssHoTNU267KlrDuGZ1WYlxDStUtKUhOaJmh112/TZmHxxUfuJqPXSOm7tDyas0OSIQ==", + "dev": true, + "license": "ISC", + "dependencies": { + "isexe": "^2.0.0" + }, + "bin": { + "which": "bin/which" + } + }, + "node_modules/npm-run-path": { + "version": "4.0.1", + "resolved": "https://registry.npmjs.org/npm-run-path/-/npm-run-path-4.0.1.tgz", + "integrity": "sha512-S48WzZW777zhNIrn7gxOlISNAqi9ZC/uQFnRdbeIHhZhCA6UqpkOT8T1G7BvfdgP4Er8gF4sUbaS0i7QvIfCWw==", + "dev": true, + "license": "MIT", + "dependencies": { + "path-key": "^3.0.0" + }, + "engines": { + "node": ">=8" + } + }, + "node_modules/object-inspect": { + "version": "1.13.4", + "resolved": "https://registry.npmjs.org/object-inspect/-/object-inspect-1.13.4.tgz", + "integrity": "sha512-W67iLl4J2EXEGTbfeHCffrjDfitvLANg0UlX3wFUUSTx92KXRFegMHUVgSqE+wvhAbi4WqjGg9czysTV2Epbew==", + "dev": true, + "license": "MIT", + "engines": { + "node": ">= 0.4" + }, + "funding": { + "url": "https://github.com/sponsors/ljharb" + } + }, + "node_modules/object-keys": { + "version": "1.1.1", + "resolved": "https://registry.npmjs.org/object-keys/-/object-keys-1.1.1.tgz", + "integrity": "sha512-NuAESUOUMrlIXOfHKzD6bpPu3tYt3xvjNdRIQ+FeT0lNb4K8WR70CaDxhuNguS2XG+GjkyMwOzsN5ZktImfhLA==", + "dev": true, + "license": "MIT", + "engines": { + "node": ">= 0.4" + } + }, + "node_modules/object.assign": { + "version": "4.1.7", + "resolved": "https://registry.npmjs.org/object.assign/-/object.assign-4.1.7.tgz", + "integrity": "sha512-nK28WOo+QIjBkDduTINE4JkF/UJJKyf2EJxvJKfblDpyg0Q+pkOHNTL0Qwy6NP6FhE/EnzV73BxxqcJaXY9anw==", + "dev": true, + "license": "MIT", + "dependencies": { + "call-bind": "^1.0.8", + "call-bound": "^1.0.3", + "define-properties": "^1.2.1", + "es-object-atoms": "^1.0.0", + "has-symbols": "^1.1.0", + "object-keys": "^1.1.1" + }, + "engines": { + "node": ">= 0.4" + }, + "funding": { + "url": "https://github.com/sponsors/ljharb" + } + }, + "node_modules/once": { + "version": "1.4.0", + "resolved": "https://registry.npmjs.org/once/-/once-1.4.0.tgz", + "integrity": "sha512-lNaJgI+2Q5URQBkccEKHTQOPaXdUxnZZElQTZY0MFUAuaEqe1E+Nyvgdz/aIyNi6Z9MzO5dv1H8n58/GELp3+w==", + "dev": true, + "license": "ISC", + "dependencies": { + "wrappy": "1" + } + }, + "node_modules/onchange": { + "version": "7.1.0", + "resolved": "https://registry.npmjs.org/onchange/-/onchange-7.1.0.tgz", + "integrity": "sha512-ZJcqsPiWUAUpvmnJri5TPBooqJOPmC0ttN65juhN15Q8xA+Nbg3BaxBHXQ45EistKKlKElb0edmbPWnKSBkvMg==", + "dev": true, + "license": "MIT", + "dependencies": { + "@blakeembrey/deque": "^1.0.5", + "@blakeembrey/template": "^1.0.0", + "arg": "^4.1.3", + "chokidar": "^3.3.1", + "cross-spawn": "^7.0.1", + "ignore": "^5.1.4", + "tree-kill": "^1.2.2" + }, + "bin": { + "onchange": "dist/bin.js" + } + }, + "node_modules/onetime": { + "version": "5.1.2", + "resolved": "https://registry.npmjs.org/onetime/-/onetime-5.1.2.tgz", + "integrity": "sha512-kbpaSSGJTWdAY5KPVeMOKXSrPtr8C8C7wodJbcsd51jRnmD+GZu8Y0VoU6Dm5Z4vWr0Ig/1NKuWRKf7j5aaYSg==", + "dev": true, + "license": "MIT", + "dependencies": { + "mimic-fn": "^2.1.0" + }, + "engines": { + "node": ">=6" + }, + "funding": { + "url": "https://github.com/sponsors/sindresorhus" + } + }, + "node_modules/optionator": { + "version": "0.9.4", + "resolved": "https://registry.npmjs.org/optionator/-/optionator-0.9.4.tgz", + "integrity": "sha512-6IpQ7mKUxRcZNLIObR0hz7lxsapSSIYNZJwXPGeF0mTVqGKFIXj1DQcMoT22S3ROcLyY/rz0PWaWZ9ayWmad9g==", + "dev": true, + "license": "MIT", + "dependencies": { + "deep-is": "^0.1.3", + "fast-levenshtein": "^2.0.6", + "levn": "^0.4.1", + "prelude-ls": "^1.2.1", + "type-check": "^0.4.0", + "word-wrap": "^1.2.5" + }, + "engines": { + "node": ">= 0.8.0" + } + }, + "node_modules/ora": { + "version": "5.4.1", + "resolved": "https://registry.npmjs.org/ora/-/ora-5.4.1.tgz", + "integrity": "sha512-5b6Y85tPxZZ7QytO+BQzysW31HJku27cRIlkbAXaNx+BdcVi+LlRFmVXzeF6a7JCwJpyw5c4b+YSVImQIrBpuQ==", + "dev": true, + "license": "MIT", + "dependencies": { + "bl": "^4.1.0", + "chalk": "^4.1.0", + "cli-cursor": "^3.1.0", + "cli-spinners": "^2.5.0", + "is-interactive": "^1.0.0", + "is-unicode-supported": "^0.1.0", + "log-symbols": "^4.1.0", + "strip-ansi": "^6.0.0", + "wcwidth": "^1.0.1" + }, + "engines": { + "node": ">=10" + }, + "funding": { + "url": "https://github.com/sponsors/sindresorhus" + } + }, + "node_modules/own-keys": { + "version": "1.0.1", + "resolved": "https://registry.npmjs.org/own-keys/-/own-keys-1.0.1.tgz", + "integrity": "sha512-qFOyK5PjiWZd+QQIh+1jhdb9LpxTF0qs7Pm8o5QHYZ0M3vKqSqzsZaEB6oWlxZ+q2sJBMI/Ktgd2N5ZwQoRHfg==", + "dev": true, + "license": "MIT", + "dependencies": { + "get-intrinsic": "^1.2.6", + "object-keys": "^1.1.1", + "safe-push-apply": "^1.0.0" + }, + "engines": { + "node": ">= 0.4" + }, + "funding": { + "url": "https://github.com/sponsors/ljharb" + } + }, + "node_modules/p-cancelable": { + "version": "2.1.1", + "resolved": "https://registry.npmjs.org/p-cancelable/-/p-cancelable-2.1.1.tgz", + "integrity": "sha512-BZOr3nRQHOntUjTrH8+Lh54smKHoHyur8We1V8DSMVrl5A2malOOwuJRnKRDjSnkoeBh4at6BwEnb5I7Jl31wg==", + "dev": true, + "license": "MIT", + "engines": { + "node": ">=8" + } + }, + "node_modules/p-limit": { + "version": "3.1.0", + "resolved": "https://registry.npmjs.org/p-limit/-/p-limit-3.1.0.tgz", + "integrity": "sha512-TYOanM3wGwNGsZN2cVTYPArw454xnXj5qmWF1bEoAc4+cU/ol7GVh7odevjp1FNHduHc3KZMcFduxU5Xc6uJRQ==", + "dev": true, + "license": "MIT", + "dependencies": { + "yocto-queue": "^0.1.0" + }, + "engines": { + "node": ">=10" + }, + "funding": { + "url": "https://github.com/sponsors/sindresorhus" + } + }, + "node_modules/p-locate": { + "version": "5.0.0", + "resolved": "https://registry.npmjs.org/p-locate/-/p-locate-5.0.0.tgz", + "integrity": "sha512-LaNjtRWUBY++zB5nE/NwcaoMylSPk+S+ZHNB1TzdbMJMny6dynpAGt7X/tl/QYq3TIeE6nxHppbo2LGymrG5Pw==", + "dev": true, + "license": "MIT", + "dependencies": { + "p-limit": "^3.0.2" + }, + "engines": { + "node": ">=10" + }, + "funding": { + "url": "https://github.com/sponsors/sindresorhus" + } + }, + "node_modules/p-try": { + "version": "2.2.0", + "resolved": "https://registry.npmjs.org/p-try/-/p-try-2.2.0.tgz", + "integrity": "sha512-R4nPAVTAU0B9D35/Gk3uJf/7XYbQcyohSKdvAxIRSNghFl4e71hVoGnBNQz9cWaXxO2I10KTC+3jMdvvoKw6dQ==", + "dev": true, + "license": "MIT", + "engines": { + "node": ">=6" + } + }, + "node_modules/pako": { + "version": "1.0.11", + "resolved": "https://registry.npmjs.org/pako/-/pako-1.0.11.tgz", + "integrity": "sha512-4hLB8Py4zZce5s4yd9XzopqwVv/yGNhV1Bl8NTmCq1763HeK2+EwVTv+leGeL13Dnh2wfbqowVPXCIO0z4taYw==", + "license": "(MIT AND Zlib)" + }, + "node_modules/parent-module": { + "version": "1.0.1", + "resolved": "https://registry.npmjs.org/parent-module/-/parent-module-1.0.1.tgz", + "integrity": "sha512-GQ2EWRpQV8/o+Aw8YqtfZZPfNRWZYkbidE9k5rpl/hC3vtHHBfGm2Ifi6qWV+coDGkrUKZAxE3Lot5kcsRlh+g==", + "dev": true, + "license": "MIT", + "dependencies": { + "callsites": "^3.0.0" + }, + "engines": { + "node": ">=6" + } + }, + "node_modules/parse-json": { + "version": "5.2.0", + "resolved": "https://registry.npmjs.org/parse-json/-/parse-json-5.2.0.tgz", + "integrity": "sha512-ayCKvm/phCGxOkYRSCM82iDwct8/EonSEgCSxWxD7ve6jHggsFl4fZVQBPRNgQoKiuV/odhFrGzQXZwbifC8Rg==", + "dev": true, + "license": "MIT", + "dependencies": { + "@babel/code-frame": "^7.0.0", + "error-ex": "^1.3.1", + "json-parse-even-better-errors": "^2.3.0", + "lines-and-columns": "^1.1.6" + }, + "engines": { + "node": ">=8" + }, + "funding": { + "url": "https://github.com/sponsors/sindresorhus" + } + }, + "node_modules/path-exists": { + "version": "4.0.0", + "resolved": "https://registry.npmjs.org/path-exists/-/path-exists-4.0.0.tgz", + "integrity": "sha512-ak9Qy5Q7jYb2Wwcey5Fpvg2KoAc/ZIhLSLOSBmRmygPsGwkVVt0fZa0qrtMz+m6tJTAHfZQ8FnmB4MG4LWy7/w==", + "dev": true, + "license": "MIT", + "engines": { + "node": ">=8" + } + }, + "node_modules/path-is-absolute": { + "version": "1.0.1", + "resolved": "https://registry.npmjs.org/path-is-absolute/-/path-is-absolute-1.0.1.tgz", + "integrity": "sha512-AVbw3UJ2e9bq64vSaS9Am0fje1Pa8pbGqTTsmXfaIiMpnr5DlDhfJOuLj9Sf95ZPVDAUerDfEk88MPmPe7UCQg==", + "dev": true, + "license": "MIT", + "engines": { + "node": ">=0.10.0" + } + }, + "node_modules/path-key": { + "version": "3.1.1", + "resolved": "https://registry.npmjs.org/path-key/-/path-key-3.1.1.tgz", + "integrity": "sha512-ojmeN0qd+y0jszEtoY48r0Peq5dwMEkIlCOu6Q5f41lfkswXuKtYrhgoTpLnyIcHm24Uhqx+5Tqm2InSwLhE6Q==", + "dev": true, + "license": "MIT", + "engines": { + "node": ">=8" + } + }, + "node_modules/path-parse": { + "version": "1.0.7", + "resolved": "https://registry.npmjs.org/path-parse/-/path-parse-1.0.7.tgz", + "integrity": "sha512-LDJzPVEEEPR+y48z93A0Ed0yXb8pAByGWo/k5YYdYgpY2/2EsOsksJrq7lOHxryrVOn1ejG6oAp8ahvOIQD8sw==", + "dev": true, + "license": "MIT" + }, + "node_modules/path-type": { + "version": "3.0.0", + "resolved": "https://registry.npmjs.org/path-type/-/path-type-3.0.0.tgz", + "integrity": "sha512-T2ZUsdZFHgA3u4e5PfPbjd7HDDpxPnQb5jN0SrDsjNSuVXHJqtwTnWqG0B1jZrgmJ/7lj1EmVIByWt1gxGkWvg==", + "dev": true, + "license": "MIT", + "dependencies": { + "pify": "^3.0.0" + }, + "engines": { + "node": ">=4" + } + }, + "node_modules/picocolors": { + "version": "1.1.1", + "resolved": "https://registry.npmjs.org/picocolors/-/picocolors-1.1.1.tgz", + "integrity": "sha512-xceH2snhtb5M9liqDsmEw56le376mTZkEX/jEb/RxNFyegNul7eNslCXP9FDj/Lcu0X8KEyMceP2ntpaHrDEVA==", + "dev": true, + "license": "ISC" + }, + "node_modules/picomatch": { + "version": "2.3.1", + "resolved": "https://registry.npmjs.org/picomatch/-/picomatch-2.3.1.tgz", + "integrity": "sha512-JU3teHTNjmE2VCGFzuY8EXzCDVwEqB2a8fsIvwaStHhAWJEeVd1o1QD80CU6+ZdEXXSLbSsuLwJjkCBWqRQUVA==", + "dev": true, + "license": "MIT", + "engines": { + "node": ">=8.6" + }, + "funding": { + "url": "https://github.com/sponsors/jonschlinkert" + } + }, + "node_modules/pidtree": { + "version": "0.3.1", + "resolved": "https://registry.npmjs.org/pidtree/-/pidtree-0.3.1.tgz", + "integrity": "sha512-qQbW94hLHEqCg7nhby4yRC7G2+jYHY4Rguc2bjw7Uug4GIJuu1tvf2uHaZv5Q8zdt+WKJ6qK1FOI6amaWUo5FA==", + "dev": true, + "license": "MIT", + "bin": { + "pidtree": "bin/pidtree.js" + }, + "engines": { + "node": ">=0.10" + } + }, + "node_modules/pify": { + "version": "3.0.0", + "resolved": "https://registry.npmjs.org/pify/-/pify-3.0.0.tgz", + "integrity": "sha512-C3FsVNH1udSEX48gGX1xfvwTWfsYWj5U+8/uK15BGzIGrKoUpghX8hWZwa/OFnakBiiVNmBvemTJR5mcy7iPcg==", + "dev": true, + "license": "MIT", + "engines": { + "node": ">=4" + } + }, + "node_modules/pirates": { + "version": "4.0.6", + "resolved": "https://registry.npmjs.org/pirates/-/pirates-4.0.6.tgz", + "integrity": "sha512-saLsH7WeYYPiD25LDuLRRY/i+6HaPYr6G1OUlN39otzkSTxKnubR9RTxS3/Kk50s1g2JTgFwWQDQyplC5/SHZg==", + "dev": true, + "license": "MIT", + "engines": { + "node": ">= 6" + } + }, + "node_modules/pkg-dir": { + "version": "4.2.0", + "resolved": "https://registry.npmjs.org/pkg-dir/-/pkg-dir-4.2.0.tgz", + "integrity": "sha512-HRDzbaKjC+AOWVXxAU/x54COGeIv9eb+6CkDSQoNTt4XyWoIJvuPsXizxu/Fr23EiekbtZwmh1IcIG/l/a10GQ==", + "dev": true, + "license": "MIT", + "dependencies": { + "find-up": "^4.0.0" + }, + "engines": { + "node": ">=8" + } + }, + "node_modules/pkg-dir/node_modules/find-up": { + "version": "4.1.0", + "resolved": "https://registry.npmjs.org/find-up/-/find-up-4.1.0.tgz", + "integrity": "sha512-PpOwAdQ/YlXQ2vj8a3h8IipDuYRi3wceVQQGYWxNINccq40Anw7BlsEXCMbt1Zt+OLA6Fq9suIpIWD0OsnISlw==", + "dev": true, + "license": "MIT", + "dependencies": { + "locate-path": "^5.0.0", + "path-exists": "^4.0.0" + }, + "engines": { + "node": ">=8" + } + }, + "node_modules/pkg-dir/node_modules/locate-path": { + "version": "5.0.0", + "resolved": "https://registry.npmjs.org/locate-path/-/locate-path-5.0.0.tgz", + "integrity": "sha512-t7hw9pI+WvuwNJXwk5zVHpyhIqzg2qTlklJOf0mVxGSbe3Fp2VieZcduNYjaLDoy6p9uGpQEGWG87WpMKlNq8g==", + "dev": true, + "license": "MIT", + "dependencies": { + "p-locate": "^4.1.0" + }, + "engines": { + "node": ">=8" + } + }, + "node_modules/pkg-dir/node_modules/p-limit": { + "version": "2.3.0", + "resolved": "https://registry.npmjs.org/p-limit/-/p-limit-2.3.0.tgz", + "integrity": "sha512-//88mFWSJx8lxCzwdAABTJL2MyWB12+eIY7MDL2SqLmAkeKU9qxRvWuSyTjm3FUmpBEMuFfckAIqEaVGUDxb6w==", + "dev": true, + "license": "MIT", + "dependencies": { + "p-try": "^2.0.0" + }, + "engines": { + "node": ">=6" + }, + "funding": { + "url": "https://github.com/sponsors/sindresorhus" + } + }, + "node_modules/pkg-dir/node_modules/p-locate": { + "version": "4.1.0", + "resolved": "https://registry.npmjs.org/p-locate/-/p-locate-4.1.0.tgz", + "integrity": "sha512-R79ZZ/0wAxKGu3oYMlz8jy/kbhsNrS7SKZ7PxEHBgJ5+F2mtFW2fK2cOtBh1cHYkQsbzFV7I+EoRKe6Yt0oK7A==", + "dev": true, + "license": "MIT", + "dependencies": { + "p-limit": "^2.2.0" + }, + "engines": { + "node": ">=8" + } + }, + "node_modules/possible-typed-array-names": { + "version": "1.1.0", + "resolved": "https://registry.npmjs.org/possible-typed-array-names/-/possible-typed-array-names-1.1.0.tgz", + "integrity": "sha512-/+5VFTchJDoVj3bhoqi6UeymcD00DAwb1nJwamzPvHEszJ4FpF6SNNbUbOS8yI56qHzdV8eK0qEfOSiodkTdxg==", + "dev": true, + "license": "MIT", + "engines": { + "node": ">= 0.4" + } + }, + "node_modules/prelude-ls": { + "version": "1.2.1", + "resolved": "https://registry.npmjs.org/prelude-ls/-/prelude-ls-1.2.1.tgz", + "integrity": "sha512-vkcDPrRZo1QZLbn5RLGPpg/WmIQ65qoWWhcGKf/b5eplkkarX0m9z8ppCat4mlOqUsWpyNuYgO3VRyrYHSzX5g==", + "dev": true, + "license": "MIT", + "engines": { + "node": ">= 0.8.0" + } + }, + "node_modules/pretty-format": { + "version": "29.7.0", + "resolved": "https://registry.npmjs.org/pretty-format/-/pretty-format-29.7.0.tgz", + "integrity": "sha512-Pdlw/oPxN+aXdmM9R00JVC9WVFoCLTKJvDVLgmJ+qAffBMxsV85l/Lu7sNx4zSzPyoL2euImuEwHhOXdEgNFZQ==", + "dev": true, + "license": "MIT", + "dependencies": { + "@jest/schemas": "^29.6.3", + "ansi-styles": "^5.0.0", + "react-is": "^18.0.0" + }, + "engines": { + "node": "^14.15.0 || ^16.10.0 || >=18.0.0" + } + }, + "node_modules/pretty-format/node_modules/ansi-styles": { + "version": "5.2.0", + "resolved": "https://registry.npmjs.org/ansi-styles/-/ansi-styles-5.2.0.tgz", + "integrity": "sha512-Cxwpt2SfTzTtXcfOlzGEee8O+c+MmUgGrNiBcXnuWxuFJHe6a5Hz7qwhwe5OgaSYI0IJvkLqWX1ASG+cJOkEiA==", + "dev": true, + "license": "MIT", + "engines": { + "node": ">=10" + }, + "funding": { + "url": "https://github.com/chalk/ansi-styles?sponsor=1" + } + }, + "node_modules/process-nextick-args": { + "version": "2.0.1", + "resolved": "https://registry.npmjs.org/process-nextick-args/-/process-nextick-args-2.0.1.tgz", + "integrity": "sha512-3ouUOpQhtgrbOa17J7+uxOTpITYWaGP7/AhoR3+A+/1e9skrzelGi/dXzEYyvbxubEF6Wn2ypscTKiKJFFn1ag==", + "license": "MIT" + }, + "node_modules/prompts": { + "version": "2.4.2", + "resolved": "https://registry.npmjs.org/prompts/-/prompts-2.4.2.tgz", + "integrity": "sha512-NxNv/kLguCA7p3jE8oL2aEBsrJWgAakBpgmgK6lpPWV+WuOmY6r2/zbAVnP+T8bQlA0nzHXSJSJW0Hq7ylaD2Q==", + "dev": true, + "license": "MIT", + "dependencies": { + "kleur": "^3.0.3", + "sisteransi": "^1.0.5" + }, + "engines": { + "node": ">= 6" + } + }, + "node_modules/pump": { + "version": "3.0.2", + "resolved": "https://registry.npmjs.org/pump/-/pump-3.0.2.tgz", + "integrity": "sha512-tUPXtzlGM8FE3P0ZL6DVs/3P58k9nk8/jZeQCurTJylQA8qFYzHFfhBJkuqyE0FifOsQ0uKWekiZ5g8wtr28cw==", + "dev": true, + "license": "MIT", + "dependencies": { + "end-of-stream": "^1.1.0", + "once": "^1.3.1" + } + }, + "node_modules/punycode": { + "version": "2.3.1", + "resolved": "https://registry.npmjs.org/punycode/-/punycode-2.3.1.tgz", + "integrity": "sha512-vYt7UD1U9Wg6138shLtLOvdAu+8DsC/ilFtEVHcH+wydcSpNE20AfSOduf6MkRFahL5FY7X1oU7nKVZFtfq8Fg==", + "dev": true, + "license": "MIT", + "engines": { + "node": ">=6" + } + }, + "node_modules/pure-rand": { + "version": "6.1.0", + "resolved": "https://registry.npmjs.org/pure-rand/-/pure-rand-6.1.0.tgz", + "integrity": "sha512-bVWawvoZoBYpp6yIoQtQXHZjmz35RSVHnUOTefl8Vcjr8snTPY1wnpSPMWekcFwbxI6gtmT7rSYPFvz71ldiOA==", + "dev": true, + "funding": [ + { + "type": "individual", + "url": "https://github.com/sponsors/dubzzz" + }, + { + "type": "opencollective", + "url": "https://opencollective.com/fast-check" + } + ], + "license": "MIT" + }, + "node_modules/queue-microtask": { + "version": "1.2.3", + "resolved": "https://registry.npmjs.org/queue-microtask/-/queue-microtask-1.2.3.tgz", + "integrity": "sha512-NuaNSa6flKT5JaSYQzJok04JzTL1CA6aGhv5rfLW3PgqA+M2ChpZQnAC8h8i4ZFkBS8X5RqkDBHA7r4hej3K9A==", + "dev": true, + "funding": [ + { + "type": "github", + "url": "https://github.com/sponsors/feross" + }, + { + "type": "patreon", + "url": "https://www.patreon.com/feross" + }, + { + "type": "consulting", + "url": "https://feross.org/support" + } + ], + "license": "MIT" + }, + "node_modules/quick-lru": { + "version": "5.1.1", + "resolved": "https://registry.npmjs.org/quick-lru/-/quick-lru-5.1.1.tgz", + "integrity": "sha512-WuyALRjWPDGtt/wzJiadO5AXY+8hZ80hVpe6MyivgraREW751X3SbhRvG3eLKOYN+8VEvqLcf3wdnt44Z4S4SA==", + "dev": true, + "license": "MIT", + "engines": { + "node": ">=10" + }, + "funding": { + "url": "https://github.com/sponsors/sindresorhus" + } + }, + "node_modules/react-is": { + "version": "18.3.1", + "resolved": "https://registry.npmjs.org/react-is/-/react-is-18.3.1.tgz", + "integrity": "sha512-/LLMVyas0ljjAtoYiPqYiL8VWXzUUdThrmU5+n20DZv+a+ClRoevUzw5JxU+Ieh5/c87ytoTBV9G1FiKfNJdmg==", + "dev": true, + "license": "MIT" + }, + "node_modules/read-pkg": { + "version": "3.0.0", + "resolved": "https://registry.npmjs.org/read-pkg/-/read-pkg-3.0.0.tgz", + "integrity": "sha512-BLq/cCO9two+lBgiTYNqD6GdtK8s4NpaWrl6/rCO9w0TUS8oJl7cmToOZfRYllKTISY6nt1U7jQ53brmKqY6BA==", + "dev": true, + "license": "MIT", + "dependencies": { + "load-json-file": "^4.0.0", + "normalize-package-data": "^2.3.2", + "path-type": "^3.0.0" + }, + "engines": { + "node": ">=4" + } + }, + "node_modules/readable-stream": { + "version": "3.6.2", + "resolved": "https://registry.npmjs.org/readable-stream/-/readable-stream-3.6.2.tgz", + "integrity": "sha512-9u/sniCrY3D5WdsERHzHE4G2YCXqoG5FTHUiCC4SIbr6XcLZBY05ya9EKjYek9O5xOAwjGq+1JdGBAS7Q9ScoA==", + "dev": true, + "license": "MIT", + "dependencies": { + "inherits": "^2.0.3", + "string_decoder": "^1.1.1", + "util-deprecate": "^1.0.1" + }, + "engines": { + "node": ">= 6" + } + }, + "node_modules/readdirp": { + "version": "3.6.0", + "resolved": "https://registry.npmjs.org/readdirp/-/readdirp-3.6.0.tgz", + "integrity": "sha512-hOS089on8RduqdbhvQ5Z37A0ESjsqz6qnRcffsMU3495FuTdqSm+7bhJ29JvIOsBDEEnan5DPu9t3To9VRlMzA==", + "dev": true, + "license": "MIT", + "dependencies": { + "picomatch": "^2.2.1" + }, + "engines": { + "node": ">=8.10.0" + } + }, + "node_modules/reflect.getprototypeof": { + "version": "1.0.10", + "resolved": "https://registry.npmjs.org/reflect.getprototypeof/-/reflect.getprototypeof-1.0.10.tgz", + "integrity": "sha512-00o4I+DVrefhv+nX0ulyi3biSHCPDe+yLv5o/p6d/UVlirijB8E16FtfwSAi4g3tcqrQ4lRAqQSoFEZJehYEcw==", + "dev": true, + "license": "MIT", + "dependencies": { + "call-bind": "^1.0.8", + "define-properties": "^1.2.1", + "es-abstract": "^1.23.9", + "es-errors": "^1.3.0", + "es-object-atoms": "^1.0.0", + "get-intrinsic": "^1.2.7", + "get-proto": "^1.0.1", + "which-builtin-type": "^1.2.1" + }, + "engines": { + "node": ">= 0.4" + }, + "funding": { + "url": "https://github.com/sponsors/ljharb" + } + }, + "node_modules/regexp.prototype.flags": { + "version": "1.5.4", + "resolved": "https://registry.npmjs.org/regexp.prototype.flags/-/regexp.prototype.flags-1.5.4.tgz", + "integrity": "sha512-dYqgNSZbDwkaJ2ceRd9ojCGjBq+mOm9LmtXnAnEGyHhN/5R7iDW2TRw3h+o/jCFxus3P2LfWIIiwowAjANm7IA==", + "dev": true, + "license": "MIT", + "dependencies": { + "call-bind": "^1.0.8", + "define-properties": "^1.2.1", + "es-errors": "^1.3.0", + "get-proto": "^1.0.1", + "gopd": "^1.2.0", + "set-function-name": "^2.0.2" + }, + "engines": { + "node": ">= 0.4" + }, + "funding": { + "url": "https://github.com/sponsors/ljharb" + } + }, + "node_modules/require-directory": { + "version": "2.1.1", + "resolved": "https://registry.npmjs.org/require-directory/-/require-directory-2.1.1.tgz", + "integrity": "sha512-fGxEI7+wsG9xrvdjsrlmL22OMTTiHRwAMroiEeMgq8gzoLC/PQr7RsRDSTLUg/bZAZtF+TVIkHc6/4RIKrui+Q==", + "dev": true, + "license": "MIT", + "engines": { + "node": ">=0.10.0" + } + }, + "node_modules/resolve": { + "version": "1.22.10", + "resolved": "https://registry.npmjs.org/resolve/-/resolve-1.22.10.tgz", + "integrity": "sha512-NPRy+/ncIMeDlTAsuqwKIiferiawhefFJtkNSW0qZJEqMEb+qBt/77B/jGeeek+F0uOeN05CDa6HXbbIgtVX4w==", + "dev": true, + "license": "MIT", + "dependencies": { + "is-core-module": "^2.16.0", + "path-parse": "^1.0.7", + "supports-preserve-symlinks-flag": "^1.0.0" + }, + "bin": { + "resolve": "bin/resolve" + }, + "engines": { + "node": ">= 0.4" + }, + "funding": { + "url": "https://github.com/sponsors/ljharb" + } + }, + "node_modules/resolve-alpn": { + "version": "1.2.1", + "resolved": "https://registry.npmjs.org/resolve-alpn/-/resolve-alpn-1.2.1.tgz", + "integrity": "sha512-0a1F4l73/ZFZOakJnQ3FvkJ2+gSTQWz/r2KE5OdDY0TxPm5h4GkqkWWfM47T7HsbnOtcJVEF4epCVy6u7Q3K+g==", + "dev": true, + "license": "MIT" + }, + "node_modules/resolve-cwd": { + "version": "3.0.0", + "resolved": "https://registry.npmjs.org/resolve-cwd/-/resolve-cwd-3.0.0.tgz", + "integrity": "sha512-OrZaX2Mb+rJCpH/6CpSqt9xFVpN++x01XnN2ie9g6P5/3xelLAkXWVADpdz1IHD/KFfEXyE6V0U01OQ3UO2rEg==", + "dev": true, + "license": "MIT", + "dependencies": { + "resolve-from": "^5.0.0" + }, + "engines": { + "node": ">=8" + } + }, + "node_modules/resolve-from": { + "version": "5.0.0", + "resolved": "https://registry.npmjs.org/resolve-from/-/resolve-from-5.0.0.tgz", + "integrity": "sha512-qYg9KP24dD5qka9J47d0aVky0N+b4fTU89LN9iDnjB5waksiC49rvMB0PrUJQGoTmH50XPiqOvAjDfaijGxYZw==", + "dev": true, + "license": "MIT", + "engines": { + "node": ">=8" + } + }, + "node_modules/resolve.exports": { + "version": "2.0.3", + "resolved": "https://registry.npmjs.org/resolve.exports/-/resolve.exports-2.0.3.tgz", + "integrity": "sha512-OcXjMsGdhL4XnbShKpAcSqPMzQoYkYyhbEaeSko47MjRP9NfEQMhZkXL1DoFlt9LWQn4YttrdnV6X2OiyzBi+A==", + "dev": true, + "license": "MIT", + "engines": { + "node": ">=10" + } + }, + "node_modules/responselike": { + "version": "2.0.1", + "resolved": "https://registry.npmjs.org/responselike/-/responselike-2.0.1.tgz", + "integrity": "sha512-4gl03wn3hj1HP3yzgdI7d3lCkF95F21Pz4BPGvKHinyQzALR5CapwC8yIi0Rh58DEMQ/SguC03wFj2k0M/mHhw==", + "dev": true, + "license": "MIT", + "dependencies": { + "lowercase-keys": "^2.0.0" + }, + "funding": { + "url": "https://github.com/sponsors/sindresorhus" + } + }, + "node_modules/restore-cursor": { + "version": "3.1.0", + "resolved": "https://registry.npmjs.org/restore-cursor/-/restore-cursor-3.1.0.tgz", + "integrity": "sha512-l+sSefzHpj5qimhFSE5a8nufZYAM3sBSVMAPtYkmC+4EH2anSGaEMXSD0izRQbu9nfyQ9y5JrVmp7E8oZrUjvA==", + "dev": true, + "license": "MIT", + "dependencies": { + "onetime": "^5.1.0", + "signal-exit": "^3.0.2" + }, + "engines": { + "node": ">=8" + } + }, + "node_modules/reusify": { + "version": "1.1.0", + "resolved": "https://registry.npmjs.org/reusify/-/reusify-1.1.0.tgz", + "integrity": "sha512-g6QUff04oZpHs0eG5p83rFLhHeV00ug/Yf9nZM6fLeUrPguBTkTQOdpAWWspMh55TZfVQDPaN3NQJfbVRAxdIw==", + "dev": true, + "license": "MIT", + "engines": { + "iojs": ">=1.0.0", + "node": ">=0.10.0" + } + }, + "node_modules/run-parallel": { + "version": "1.2.0", + "resolved": "https://registry.npmjs.org/run-parallel/-/run-parallel-1.2.0.tgz", + "integrity": "sha512-5l4VyZR86LZ/lDxZTR6jqL8AFE2S0IFLMP26AbjsLVADxHdhB/c0GUsH+y39UfCi3dzz8OlQuPmnaJOMoDHQBA==", + "dev": true, + "funding": [ + { + "type": "github", + "url": "https://github.com/sponsors/feross" + }, + { + "type": "patreon", + "url": "https://www.patreon.com/feross" + }, + { + "type": "consulting", + "url": "https://feross.org/support" + } + ], + "license": "MIT", + "dependencies": { + "queue-microtask": "^1.2.2" + } + }, + "node_modules/safe-array-concat": { + "version": "1.1.3", + "resolved": "https://registry.npmjs.org/safe-array-concat/-/safe-array-concat-1.1.3.tgz", + "integrity": "sha512-AURm5f0jYEOydBj7VQlVvDrjeFgthDdEF5H1dP+6mNpoXOMo1quQqJ4wvJDyRZ9+pO3kGWoOdmV08cSv2aJV6Q==", + "dev": true, + "license": "MIT", + "dependencies": { + "call-bind": "^1.0.8", + "call-bound": "^1.0.2", + "get-intrinsic": "^1.2.6", + "has-symbols": "^1.1.0", + "isarray": "^2.0.5" + }, + "engines": { + "node": ">=0.4" + }, + "funding": { + "url": "https://github.com/sponsors/ljharb" + } + }, + "node_modules/safe-buffer": { + "version": "5.2.1", + "resolved": "https://registry.npmjs.org/safe-buffer/-/safe-buffer-5.2.1.tgz", + "integrity": "sha512-rp3So07KcdmmKbGvgaNxQSJr7bGVSVk5S9Eq1F+ppbRo70+YeaDxkw5Dd8NPN+GD6bjnYm2VuPuCXmpuYvmCXQ==", + "dev": true, + "funding": [ + { + "type": "github", + "url": "https://github.com/sponsors/feross" + }, + { + "type": "patreon", + "url": "https://www.patreon.com/feross" + }, + { + "type": "consulting", + "url": "https://feross.org/support" + } + ], + "license": "MIT" + }, + "node_modules/safe-push-apply": { + "version": "1.0.0", + "resolved": "https://registry.npmjs.org/safe-push-apply/-/safe-push-apply-1.0.0.tgz", + "integrity": "sha512-iKE9w/Z7xCzUMIZqdBsp6pEQvwuEebH4vdpjcDWnyzaI6yl6O9FHvVpmGelvEHNsoY6wGblkxR6Zty/h00WiSA==", + "dev": true, + "license": "MIT", + "dependencies": { + "es-errors": "^1.3.0", + "isarray": "^2.0.5" + }, + "engines": { + "node": ">= 0.4" + }, + "funding": { + "url": "https://github.com/sponsors/ljharb" + } + }, + "node_modules/safe-regex-test": { + "version": "1.1.0", + "resolved": "https://registry.npmjs.org/safe-regex-test/-/safe-regex-test-1.1.0.tgz", + "integrity": "sha512-x/+Cz4YrimQxQccJf5mKEbIa1NzeCRNI5Ecl/ekmlYaampdNLPalVyIcCZNNH3MvmqBugV5TMYZXv0ljslUlaw==", + "dev": true, + "license": "MIT", + "dependencies": { + "call-bound": "^1.0.2", + "es-errors": "^1.3.0", + "is-regex": "^1.2.1" + }, + "engines": { + "node": ">= 0.4" + }, + "funding": { + "url": "https://github.com/sponsors/ljharb" + } + }, + "node_modules/semver": { + "version": "6.3.1", + "resolved": "https://registry.npmjs.org/semver/-/semver-6.3.1.tgz", + "integrity": "sha512-BR7VvDCVHO+q2xBEWskxS6DJE1qRnb7DxzUrogb71CWoSficBxYsiAGd+Kl0mmq/MprG9yArRkyrQxTO6XjMzA==", + "dev": true, + "license": "ISC", + "bin": { + "semver": "bin/semver.js" + } + }, + "node_modules/set-function-length": { + "version": "1.2.2", + "resolved": "https://registry.npmjs.org/set-function-length/-/set-function-length-1.2.2.tgz", + "integrity": "sha512-pgRc4hJ4/sNjWCSS9AmnS40x3bNMDTknHgL5UaMBTMyJnU90EgWh1Rz+MC9eFu4BuN/UwZjKQuY/1v3rM7HMfg==", + "dev": true, + "license": "MIT", + "dependencies": { + "define-data-property": "^1.1.4", + "es-errors": "^1.3.0", + "function-bind": "^1.1.2", + "get-intrinsic": "^1.2.4", + "gopd": "^1.0.1", + "has-property-descriptors": "^1.0.2" + }, + "engines": { + "node": ">= 0.4" + } + }, + "node_modules/set-function-name": { + "version": "2.0.2", + "resolved": "https://registry.npmjs.org/set-function-name/-/set-function-name-2.0.2.tgz", + "integrity": "sha512-7PGFlmtwsEADb0WYyvCMa1t+yke6daIG4Wirafur5kcf+MhUnPms1UeR0CKQdTZD81yESwMHbtn+TR+dMviakQ==", + "dev": true, + "license": "MIT", + "dependencies": { + "define-data-property": "^1.1.4", + "es-errors": "^1.3.0", + "functions-have-names": "^1.2.3", + "has-property-descriptors": "^1.0.2" + }, + "engines": { + "node": ">= 0.4" + } + }, + "node_modules/set-proto": { + "version": "1.0.0", + "resolved": "https://registry.npmjs.org/set-proto/-/set-proto-1.0.0.tgz", + "integrity": "sha512-RJRdvCo6IAnPdsvP/7m6bsQqNnn1FCBX5ZNtFL98MmFF/4xAIJTIg1YbHW5DC2W5SKZanrC6i4HsJqlajw/dZw==", + "dev": true, + "license": "MIT", + "dependencies": { + "dunder-proto": "^1.0.1", + "es-errors": "^1.3.0", + "es-object-atoms": "^1.0.0" + }, + "engines": { + "node": ">= 0.4" + } + }, + "node_modules/setimmediate": { + "version": "1.0.5", + "resolved": "https://registry.npmjs.org/setimmediate/-/setimmediate-1.0.5.tgz", + "integrity": "sha512-MATJdZp8sLqDl/68LfQmbP8zKPLQNV6BIZoIgrscFDQ+RsvK/BxeDQOgyxKKoh0y/8h3BqVFnCqQ/gd+reiIXA==", + "license": "MIT" + }, + "node_modules/shebang-command": { + "version": "2.0.0", + "resolved": "https://registry.npmjs.org/shebang-command/-/shebang-command-2.0.0.tgz", + "integrity": "sha512-kHxr2zZpYtdmrN1qDjrrX/Z1rR1kG8Dx+gkpK1G4eXmvXswmcE1hTWBWYUzlraYw1/yZp6YuDY77YtvbN0dmDA==", + "dev": true, + "license": "MIT", + "dependencies": { + "shebang-regex": "^3.0.0" + }, + "engines": { + "node": ">=8" + } + }, + "node_modules/shebang-regex": { + "version": "3.0.0", + "resolved": "https://registry.npmjs.org/shebang-regex/-/shebang-regex-3.0.0.tgz", + "integrity": "sha512-7++dFhtcx3353uBaq8DDR4NuxBetBzC7ZQOhmTQInHEd6bSrXdiEyzCvG07Z44UYdLShWUyXt5M/yhz8ekcb1A==", + "dev": true, + "license": "MIT", + "engines": { + "node": ">=8" + } + }, + "node_modules/shell-quote": { + "version": "1.8.2", + "resolved": "https://registry.npmjs.org/shell-quote/-/shell-quote-1.8.2.tgz", + "integrity": "sha512-AzqKpGKjrj7EM6rKVQEPpB288oCfnrEIuyoT9cyF4nmGa7V8Zk6f7RRqYisX8X9m+Q7bd632aZW4ky7EhbQztA==", + "dev": true, + "license": "MIT", + "engines": { + "node": ">= 0.4" + }, + "funding": { + "url": "https://github.com/sponsors/ljharb" + } + }, + "node_modules/side-channel": { + "version": "1.1.0", + "resolved": "https://registry.npmjs.org/side-channel/-/side-channel-1.1.0.tgz", + "integrity": "sha512-ZX99e6tRweoUXqR+VBrslhda51Nh5MTQwou5tnUDgbtyM0dBgmhEDtWGP/xbKn6hqfPRHujUNwz5fy/wbbhnpw==", + "dev": true, + "license": "MIT", + "dependencies": { + "es-errors": "^1.3.0", + "object-inspect": "^1.13.3", + "side-channel-list": "^1.0.0", + "side-channel-map": "^1.0.1", + "side-channel-weakmap": "^1.0.2" + }, + "engines": { + "node": ">= 0.4" + }, + "funding": { + "url": "https://github.com/sponsors/ljharb" + } + }, + "node_modules/side-channel-list": { + "version": "1.0.0", + "resolved": "https://registry.npmjs.org/side-channel-list/-/side-channel-list-1.0.0.tgz", + "integrity": "sha512-FCLHtRD/gnpCiCHEiJLOwdmFP+wzCmDEkc9y7NsYxeF4u7Btsn1ZuwgwJGxImImHicJArLP4R0yX4c2KCrMrTA==", + "dev": true, + "license": "MIT", + "dependencies": { + "es-errors": "^1.3.0", + "object-inspect": "^1.13.3" + }, + "engines": { + "node": ">= 0.4" + }, + "funding": { + "url": "https://github.com/sponsors/ljharb" + } + }, + "node_modules/side-channel-map": { + "version": "1.0.1", + "resolved": "https://registry.npmjs.org/side-channel-map/-/side-channel-map-1.0.1.tgz", + "integrity": "sha512-VCjCNfgMsby3tTdo02nbjtM/ewra6jPHmpThenkTYh8pG9ucZ/1P8So4u4FGBek/BjpOVsDCMoLA/iuBKIFXRA==", + "dev": true, + "license": "MIT", + "dependencies": { + "call-bound": "^1.0.2", + "es-errors": "^1.3.0", + "get-intrinsic": "^1.2.5", + "object-inspect": "^1.13.3" + }, + "engines": { + "node": ">= 0.4" + }, + "funding": { + "url": "https://github.com/sponsors/ljharb" + } + }, + "node_modules/side-channel-weakmap": { + "version": "1.0.2", + "resolved": "https://registry.npmjs.org/side-channel-weakmap/-/side-channel-weakmap-1.0.2.tgz", + "integrity": "sha512-WPS/HvHQTYnHisLo9McqBHOJk2FkHO/tlpvldyrnem4aeQp4hai3gythswg6p01oSoTl58rcpiFAjF2br2Ak2A==", + "dev": true, + "license": "MIT", + "dependencies": { + "call-bound": "^1.0.2", + "es-errors": "^1.3.0", + "get-intrinsic": "^1.2.5", + "object-inspect": "^1.13.3", + "side-channel-map": "^1.0.1" + }, + "engines": { + "node": ">= 0.4" + }, + "funding": { + "url": "https://github.com/sponsors/ljharb" + } + }, + "node_modules/signal-exit": { + "version": "3.0.7", + "resolved": "https://registry.npmjs.org/signal-exit/-/signal-exit-3.0.7.tgz", + "integrity": "sha512-wnD2ZE+l+SPC/uoS0vXeE9L1+0wuaMqKlfz9AMUo38JsyLSBWSFcHR1Rri62LZc12vLr1gb3jl7iwQhgwpAbGQ==", + "dev": true, + "license": "ISC" + }, + "node_modules/sisteransi": { + "version": "1.0.5", + "resolved": "https://registry.npmjs.org/sisteransi/-/sisteransi-1.0.5.tgz", + "integrity": "sha512-bLGGlR1QxBcynn2d5YmDX4MGjlZvy2MRBDRNHLJ8VI6l6+9FUiyTFNJ0IveOSP0bcXgVDPRcfGqA0pjaqUpfVg==", + "dev": true, + "license": "MIT" + }, + "node_modules/slash": { + "version": "3.0.0", + "resolved": "https://registry.npmjs.org/slash/-/slash-3.0.0.tgz", + "integrity": "sha512-g9Q1haeby36OSStwb4ntCGGGaKsaVSjQ68fBxoQcutl5fS1vuY18H3wSt3jFyFtrkx+Kz0V1G85A4MyAdDMi2Q==", + "dev": true, + "license": "MIT", + "engines": { + "node": ">=8" + } + }, + "node_modules/source-map": { + "version": "0.6.1", + "resolved": "https://registry.npmjs.org/source-map/-/source-map-0.6.1.tgz", + "integrity": "sha512-UjgapumWlbMhkBgzT7Ykc5YXUT46F0iKu8SGXq0bcwP5dz/h0Plj6enJqjz1Zbq2l5WaqYnrVbwWOWMyF3F47g==", + "dev": true, + "license": "BSD-3-Clause", + "engines": { + "node": ">=0.10.0" + } + }, + "node_modules/source-map-support": { + "version": "0.5.13", + "resolved": "https://registry.npmjs.org/source-map-support/-/source-map-support-0.5.13.tgz", + "integrity": "sha512-SHSKFHadjVA5oR4PPqhtAVdcBWwRYVd6g6cAXnIbRiIwc2EhPrTuKUBdSLvlEKyIP3GCf89fltvcZiP9MMFA1w==", + "dev": true, + "license": "MIT", + "dependencies": { + "buffer-from": "^1.0.0", + "source-map": "^0.6.0" + } + }, + "node_modules/spdx-correct": { + "version": "3.2.0", + "resolved": "https://registry.npmjs.org/spdx-correct/-/spdx-correct-3.2.0.tgz", + "integrity": "sha512-kN9dJbvnySHULIluDHy32WHRUu3Og7B9sbY7tsFLctQkIqnMh3hErYgdMjTYuqmcXX+lK5T1lnUt3G7zNswmZA==", + "dev": true, + "license": "Apache-2.0", + "dependencies": { + "spdx-expression-parse": "^3.0.0", + "spdx-license-ids": "^3.0.0" + } + }, + "node_modules/spdx-exceptions": { + "version": "2.5.0", + "resolved": "https://registry.npmjs.org/spdx-exceptions/-/spdx-exceptions-2.5.0.tgz", + "integrity": "sha512-PiU42r+xO4UbUS1buo3LPJkjlO7430Xn5SVAhdpzzsPHsjbYVflnnFdATgabnLude+Cqu25p6N+g2lw/PFsa4w==", + "dev": true, + "license": "CC-BY-3.0" + }, + "node_modules/spdx-expression-parse": { + "version": "3.0.1", + "resolved": "https://registry.npmjs.org/spdx-expression-parse/-/spdx-expression-parse-3.0.1.tgz", + "integrity": "sha512-cbqHunsQWnJNE6KhVSMsMeH5H/L9EpymbzqTQ3uLwNCLZ1Q481oWaofqH7nO6V07xlXwY6PhQdQ2IedWx/ZK4Q==", + "dev": true, + "license": "MIT", + "dependencies": { + "spdx-exceptions": "^2.1.0", + "spdx-license-ids": "^3.0.0" + } + }, + "node_modules/spdx-license-ids": { + "version": "3.0.21", + "resolved": "https://registry.npmjs.org/spdx-license-ids/-/spdx-license-ids-3.0.21.tgz", + "integrity": "sha512-Bvg/8F5XephndSK3JffaRqdT+gyhfqIPwDHpX80tJrF8QQRYMo8sNMeaZ2Dp5+jhwKnUmIOyFFQfHRkjJm5nXg==", + "dev": true, + "license": "CC0-1.0" + }, + "node_modules/split": { + "version": "1.0.1", + "resolved": "https://registry.npmjs.org/split/-/split-1.0.1.tgz", + "integrity": "sha512-mTyOoPbrivtXnwnIxZRFYRrPNtEFKlpB2fvjSnCQUiAA6qAZzqwna5envK4uk6OIeP17CsdF3rSBGYVBsU0Tkg==", + "dev": true, + "license": "MIT", + "dependencies": { + "through": "2" + }, + "engines": { + "node": "*" + } + }, + "node_modules/sprintf-js": { + "version": "1.0.3", + "resolved": "https://registry.npmjs.org/sprintf-js/-/sprintf-js-1.0.3.tgz", + "integrity": "sha512-D9cPgkvLlV3t3IzL0D0YLvGA9Ahk4PcvVwUbN0dSGr1aP0Nrt4AEnTUbuGvquEC0mA64Gqt1fzirlRs5ibXx8g==", + "dev": true, + "license": "BSD-3-Clause" + }, + "node_modules/stack-utils": { + "version": "2.0.6", + "resolved": "https://registry.npmjs.org/stack-utils/-/stack-utils-2.0.6.tgz", + "integrity": "sha512-XlkWvfIm6RmsWtNJx+uqtKLS8eqFbxUg0ZzLXqY0caEy9l7hruX8IpiDnjsLavoBgqCCR71TqWO8MaXYheJ3RQ==", + "dev": true, + "license": "MIT", + "dependencies": { + "escape-string-regexp": "^2.0.0" + }, + "engines": { + "node": ">=10" + } + }, + "node_modules/string_decoder": { + "version": "1.3.0", + "resolved": "https://registry.npmjs.org/string_decoder/-/string_decoder-1.3.0.tgz", + "integrity": "sha512-hkRX8U1WjJFd8LsDJ2yQ/wWWxaopEsABU1XfkM8A+j0+85JAGppt16cr1Whg6KIbb4okU6Mql6BOj+uup/wKeA==", + "dev": true, + "license": "MIT", + "dependencies": { + "safe-buffer": "~5.2.0" + } + }, + "node_modules/string-length": { + "version": "4.0.2", + "resolved": "https://registry.npmjs.org/string-length/-/string-length-4.0.2.tgz", + "integrity": "sha512-+l6rNN5fYHNhZZy41RXsYptCjA2Igmq4EG7kZAYFQI1E1VTXarr6ZPXBg6eq7Y6eK4FEhY6AJlyuFIb/v/S0VQ==", + "dev": true, + "license": "MIT", + "dependencies": { + "char-regex": "^1.0.2", + "strip-ansi": "^6.0.0" + }, + "engines": { + "node": ">=10" + } + }, + "node_modules/string-width": { + "version": "4.2.3", + "resolved": "https://registry.npmjs.org/string-width/-/string-width-4.2.3.tgz", + "integrity": "sha512-wKyQRQpjJ0sIp62ErSZdGsjMJWsap5oRNihHhu6G7JVO/9jIB6UyevL+tXuOqrng8j/cxKTWyWUwvSTriiZz/g==", + "dev": true, + "license": "MIT", + "dependencies": { + "emoji-regex": "^8.0.0", + "is-fullwidth-code-point": "^3.0.0", + "strip-ansi": "^6.0.1" + }, + "engines": { + "node": ">=8" + } + }, + "node_modules/string.prototype.padend": { + "version": "3.1.6", + "resolved": "https://registry.npmjs.org/string.prototype.padend/-/string.prototype.padend-3.1.6.tgz", + "integrity": "sha512-XZpspuSB7vJWhvJc9DLSlrXl1mcA2BdoY5jjnS135ydXqLoqhs96JjDtCkjJEQHvfqZIp9hBuBMgI589peyx9Q==", + "dev": true, + "license": "MIT", + "dependencies": { + "call-bind": "^1.0.7", + "define-properties": "^1.2.1", + "es-abstract": "^1.23.2", + "es-object-atoms": "^1.0.0" + }, + "engines": { + "node": ">= 0.4" + }, + "funding": { + "url": "https://github.com/sponsors/ljharb" + } + }, + "node_modules/string.prototype.trim": { + "version": "1.2.10", + "resolved": "https://registry.npmjs.org/string.prototype.trim/-/string.prototype.trim-1.2.10.tgz", + "integrity": "sha512-Rs66F0P/1kedk5lyYyH9uBzuiI/kNRmwJAR9quK6VOtIpZ2G+hMZd+HQbbv25MgCA6gEffoMZYxlTod4WcdrKA==", + "dev": true, + "license": "MIT", + "dependencies": { + "call-bind": "^1.0.8", + "call-bound": "^1.0.2", + "define-data-property": "^1.1.4", + "define-properties": "^1.2.1", + "es-abstract": "^1.23.5", + "es-object-atoms": "^1.0.0", + "has-property-descriptors": "^1.0.2" + }, + "engines": { + "node": ">= 0.4" + }, + "funding": { + "url": "https://github.com/sponsors/ljharb" + } + }, + "node_modules/string.prototype.trimend": { + "version": "1.0.9", + "resolved": "https://registry.npmjs.org/string.prototype.trimend/-/string.prototype.trimend-1.0.9.tgz", + "integrity": "sha512-G7Ok5C6E/j4SGfyLCloXTrngQIQU3PWtXGst3yM7Bea9FRURf1S42ZHlZZtsNque2FN2PoUhfZXYLNWwEr4dLQ==", + "dev": true, + "license": "MIT", + "dependencies": { + "call-bind": "^1.0.8", + "call-bound": "^1.0.2", + "define-properties": "^1.2.1", + "es-object-atoms": "^1.0.0" + }, + "engines": { + "node": ">= 0.4" + }, + "funding": { + "url": "https://github.com/sponsors/ljharb" + } + }, + "node_modules/string.prototype.trimstart": { + "version": "1.0.8", + "resolved": "https://registry.npmjs.org/string.prototype.trimstart/-/string.prototype.trimstart-1.0.8.tgz", + "integrity": "sha512-UXSH262CSZY1tfu3G3Secr6uGLCFVPMhIqHjlgCUtCCcgihYc/xKs9djMTMUOb2j1mVSeU8EU6NWc/iQKU6Gfg==", + "dev": true, + "license": "MIT", + "dependencies": { + "call-bind": "^1.0.7", + "define-properties": "^1.2.1", + "es-object-atoms": "^1.0.0" + }, + "engines": { + "node": ">= 0.4" + }, + "funding": { + "url": "https://github.com/sponsors/ljharb" + } + }, + "node_modules/strip-ansi": { + "version": "6.0.1", + "resolved": "https://registry.npmjs.org/strip-ansi/-/strip-ansi-6.0.1.tgz", + "integrity": "sha512-Y38VPSHcqkFrCpFnQ9vuSXmquuv5oXOKpGeT6aGrr3o3Gc9AlVa6JBfUSOCnbxGGZF+/0ooI7KrPuUSztUdU5A==", + "dev": true, + "license": "MIT", + "dependencies": { + "ansi-regex": "^5.0.1" + }, + "engines": { + "node": ">=8" + } + }, + "node_modules/strip-bom": { + "version": "4.0.0", + "resolved": "https://registry.npmjs.org/strip-bom/-/strip-bom-4.0.0.tgz", + "integrity": "sha512-3xurFv5tEgii33Zi8Jtp55wEIILR9eh34FAW00PZf+JnSsTmV/ioewSgQl97JHvgjoRGwPShsWm+IdrxB35d0w==", + "dev": true, + "license": "MIT", + "engines": { + "node": ">=8" + } + }, + "node_modules/strip-final-newline": { + "version": "2.0.0", + "resolved": "https://registry.npmjs.org/strip-final-newline/-/strip-final-newline-2.0.0.tgz", + "integrity": "sha512-BrpvfNAE3dcvq7ll3xVumzjKjZQ5tI1sEUIKr3Uoks0XUl45St3FlatVqef9prk4jRDzhW6WZg+3bk93y6pLjA==", + "dev": true, + "license": "MIT", + "engines": { + "node": ">=6" + } + }, + "node_modules/strip-json-comments": { + "version": "3.1.1", + "resolved": "https://registry.npmjs.org/strip-json-comments/-/strip-json-comments-3.1.1.tgz", + "integrity": "sha512-6fPc+R4ihwqP6N/aIv2f1gMH8lOVtWQHoqC4yK6oSDVVocumAsfCqjkXnqiYMhmMwS/mEHLp7Vehlt3ql6lEig==", + "dev": true, + "license": "MIT", + "engines": { + "node": ">=8" + }, + "funding": { + "url": "https://github.com/sponsors/sindresorhus" + } + }, + "node_modules/supports-color": { + "version": "7.2.0", + "resolved": "https://registry.npmjs.org/supports-color/-/supports-color-7.2.0.tgz", + "integrity": "sha512-qpCAvRl9stuOHveKsn7HncJRvv501qIacKzQlO/+Lwxc9+0q2wLyv4Dfvt80/DPn2pqOBsJdDiogXGR9+OvwRw==", + "dev": true, + "license": "MIT", + "dependencies": { + "has-flag": "^4.0.0" + }, + "engines": { + "node": ">=8" + } + }, + "node_modules/supports-hyperlinks": { + "version": "2.3.0", + "resolved": "https://registry.npmjs.org/supports-hyperlinks/-/supports-hyperlinks-2.3.0.tgz", + "integrity": "sha512-RpsAZlpWcDwOPQA22aCH4J0t7L8JmAvsCxfOSEwm7cQs3LshN36QaTkwd70DnBOXDWGssw2eUoc8CaRWT0XunA==", + "dev": true, + "license": "MIT", + "dependencies": { + "has-flag": "^4.0.0", + "supports-color": "^7.0.0" + }, + "engines": { + "node": ">=8" + } + }, + "node_modules/supports-preserve-symlinks-flag": { + "version": "1.0.0", + "resolved": "https://registry.npmjs.org/supports-preserve-symlinks-flag/-/supports-preserve-symlinks-flag-1.0.0.tgz", + "integrity": "sha512-ot0WnXS9fgdkgIcePe6RHNk1WA8+muPa6cSjeR3V8K27q9BB1rTE3R1p7Hv0z1ZyAc8s6Vvv8DIyWf681MAt0w==", + "dev": true, + "license": "MIT", + "engines": { + "node": ">= 0.4" + }, + "funding": { + "url": "https://github.com/sponsors/ljharb" + } + }, + "node_modules/terminal-link": { + "version": "2.1.1", + "resolved": "https://registry.npmjs.org/terminal-link/-/terminal-link-2.1.1.tgz", + "integrity": "sha512-un0FmiRUQNr5PJqy9kP7c40F5BOfpGlYTrxonDChEZB7pzZxRNp/bt+ymiy9/npwXya9KH99nJ/GXFIiUkYGFQ==", + "dev": true, + "license": "MIT", + "dependencies": { + "ansi-escapes": "^4.2.1", + "supports-hyperlinks": "^2.0.0" + }, + "engines": { + "node": ">=8" + }, + "funding": { + "url": "https://github.com/sponsors/sindresorhus" + } + }, + "node_modules/test-exclude": { + "version": "6.0.0", + "resolved": "https://registry.npmjs.org/test-exclude/-/test-exclude-6.0.0.tgz", + "integrity": "sha512-cAGWPIyOHU6zlmg88jwm7VRyXnMN7iV68OGAbYDk/Mh/xC/pzVPlQtY6ngoIH/5/tciuhGfvESU8GrHrcxD56w==", + "dev": true, + "license": "ISC", + "dependencies": { + "@istanbuljs/schema": "^0.1.2", + "glob": "^7.1.4", + "minimatch": "^3.0.4" + }, + "engines": { + "node": ">=8" + } + }, + "node_modules/through": { + "version": "2.3.8", + "resolved": "https://registry.npmjs.org/through/-/through-2.3.8.tgz", + "integrity": "sha512-w89qg7PI8wAdvX60bMDP+bFoD5Dvhm9oLheFp5O4a2QF0cSBGsBX4qZmadPMvVqlLJBBci+WqGGOAPvcDeNSVg==", + "dev": true, + "license": "MIT" + }, + "node_modules/tinyglobby": { + "version": "0.2.12", + "resolved": "https://registry.npmjs.org/tinyglobby/-/tinyglobby-0.2.12.tgz", + "integrity": "sha512-qkf4trmKSIiMTs/E63cxH+ojC2unam7rJ0WrauAzpT3ECNTxGRMlaXxVbfxMUC/w0LaYk6jQ4y/nGR9uBO3tww==", + "dev": true, + "license": "MIT", + "dependencies": { + "fdir": "^6.4.3", + "picomatch": "^4.0.2" + }, + "engines": { + "node": ">=12.0.0" + }, + "funding": { + "url": "https://github.com/sponsors/SuperchupuDev" + } + }, + "node_modules/tinyglobby/node_modules/fdir": { + "version": "6.4.3", + "resolved": "https://registry.npmjs.org/fdir/-/fdir-6.4.3.tgz", + "integrity": "sha512-PMXmW2y1hDDfTSRc9gaXIuCCRpuoz3Kaz8cUelp3smouvfT632ozg2vrT6lJsHKKOF59YLbOGfAWGUcKEfRMQw==", + "dev": true, + "license": "MIT", + "peerDependencies": { + "picomatch": "^3 || ^4" + }, + "peerDependenciesMeta": { + "picomatch": { + "optional": true + } + } + }, + "node_modules/tinyglobby/node_modules/picomatch": { + "version": "4.0.2", + "resolved": "https://registry.npmjs.org/picomatch/-/picomatch-4.0.2.tgz", + "integrity": "sha512-M7BAV6Rlcy5u+m6oPhAPFgJTzAioX/6B0DxyvDlo9l8+T3nLKbrczg2WLUyzd45L8RqfUMyGPzekbMvX2Ldkwg==", + "dev": true, + "license": "MIT", + "engines": { + "node": ">=12" + }, + "funding": { + "url": "https://github.com/sponsors/jonschlinkert" + } + }, + "node_modules/tmp": { + "version": "0.2.5", + "resolved": "https://registry.npmjs.org/tmp/-/tmp-0.2.5.tgz", + "integrity": "sha512-voyz6MApa1rQGUxT3E+BK7/ROe8itEx7vD8/HEvt4xwXucvQ5G5oeEiHkmHZJuBO21RpOf+YYm9MOivj709jow==", + "license": "MIT", + "engines": { + "node": ">=14.14" + } + }, + "node_modules/tmpl": { + "version": "1.0.5", + "resolved": "https://registry.npmjs.org/tmpl/-/tmpl-1.0.5.tgz", + "integrity": "sha512-3f0uOEAQwIqGuWW2MVzYg8fV/QNnc/IpuJNG837rLuczAaLVHslWHZQj4IGiEl5Hs3kkbhwL9Ab7Hrsmuj+Smw==", + "dev": true, + "license": "BSD-3-Clause" + }, + "node_modules/to-regex-range": { + "version": "5.0.1", + "resolved": "https://registry.npmjs.org/to-regex-range/-/to-regex-range-5.0.1.tgz", + "integrity": "sha512-65P7iz6X5yEr1cwcgvQxbbIw7Uk3gOy5dIdtZ4rDveLqhrdJP+Li/Hx6tyK0NEb+2GCyneCMJiGqrADCSNk8sQ==", + "dev": true, + "license": "MIT", + "dependencies": { + "is-number": "^7.0.0" + }, + "engines": { + "node": ">=8.0" + } + }, + "node_modules/tree-kill": { + "version": "1.2.2", + "resolved": "https://registry.npmjs.org/tree-kill/-/tree-kill-1.2.2.tgz", + "integrity": "sha512-L0Orpi8qGpRG//Nd+H90vFB+3iHnue1zSSGmNOOCh1GLJ7rUKVwV2HvijphGQS2UmhUZewS9VgvxYIdgr+fG1A==", + "dev": true, + "license": "MIT", + "bin": { + "tree-kill": "cli.js" + } + }, + "node_modules/ts-api-utils": { + "version": "2.1.0", + "resolved": "https://registry.npmjs.org/ts-api-utils/-/ts-api-utils-2.1.0.tgz", + "integrity": "sha512-CUgTZL1irw8u29bzrOD/nH85jqyc74D6SshFgujOIA7osm2Rz7dYH77agkx7H4FBNxDq7Cjf+IjaX/8zwFW+ZQ==", + "dev": true, + "license": "MIT", + "engines": { + "node": ">=18.12" + }, + "peerDependencies": { + "typescript": ">=4.8.4" + } + }, + "node_modules/type-check": { + "version": "0.4.0", + "resolved": "https://registry.npmjs.org/type-check/-/type-check-0.4.0.tgz", + "integrity": "sha512-XleUoc9uwGXqjWwXaUTZAmzMcFZ5858QA2vvx1Ur5xIcixXIP+8LnFDgRplU30us6teqdlskFfu+ae4K79Ooew==", + "dev": true, + "license": "MIT", + "dependencies": { + "prelude-ls": "^1.2.1" + }, + "engines": { + "node": ">= 0.8.0" + } + }, + "node_modules/type-detect": { + "version": "4.0.8", + "resolved": "https://registry.npmjs.org/type-detect/-/type-detect-4.0.8.tgz", + "integrity": "sha512-0fr/mIH1dlO+x7TlcMy+bIDqKPsw/70tVyeHW787goQjhmqaZe10uwLujubK9q9Lg6Fiho1KUKDYz0Z7k7g5/g==", + "dev": true, + "license": "MIT", + "engines": { + "node": ">=4" + } + }, + "node_modules/type-fest": { + "version": "0.21.3", + "resolved": "https://registry.npmjs.org/type-fest/-/type-fest-0.21.3.tgz", + "integrity": "sha512-t0rzBq87m3fVcduHDUFhKmyyX+9eo6WQjZvf51Ea/M0Q7+T374Jp1aUiyUl0GKxp8M/OETVHSDvmkyPgvX+X2w==", + "dev": true, + "license": "(MIT OR CC0-1.0)", + "engines": { + "node": ">=10" + }, + "funding": { + "url": "https://github.com/sponsors/sindresorhus" + } + }, + "node_modules/typed-array-buffer": { + "version": "1.0.3", + "resolved": "https://registry.npmjs.org/typed-array-buffer/-/typed-array-buffer-1.0.3.tgz", + "integrity": "sha512-nAYYwfY3qnzX30IkA6AQZjVbtK6duGontcQm1WSG1MD94YLqK0515GNApXkoxKOWMusVssAHWLh9SeaoefYFGw==", + "dev": true, + "license": "MIT", + "dependencies": { + "call-bound": "^1.0.3", + "es-errors": "^1.3.0", + "is-typed-array": "^1.1.14" + }, + "engines": { + "node": ">= 0.4" + } + }, + "node_modules/typed-array-byte-length": { + "version": "1.0.3", + "resolved": "https://registry.npmjs.org/typed-array-byte-length/-/typed-array-byte-length-1.0.3.tgz", + "integrity": "sha512-BaXgOuIxz8n8pIq3e7Atg/7s+DpiYrxn4vdot3w9KbnBhcRQq6o3xemQdIfynqSeXeDrF32x+WvfzmOjPiY9lg==", + "dev": true, + "license": "MIT", + "dependencies": { + "call-bind": "^1.0.8", + "for-each": "^0.3.3", + "gopd": "^1.2.0", + "has-proto": "^1.2.0", + "is-typed-array": "^1.1.14" + }, + "engines": { + "node": ">= 0.4" + }, + "funding": { + "url": "https://github.com/sponsors/ljharb" + } + }, + "node_modules/typed-array-byte-offset": { + "version": "1.0.4", + "resolved": "https://registry.npmjs.org/typed-array-byte-offset/-/typed-array-byte-offset-1.0.4.tgz", + "integrity": "sha512-bTlAFB/FBYMcuX81gbL4OcpH5PmlFHqlCCpAl8AlEzMz5k53oNDvN8p1PNOWLEmI2x4orp3raOFB51tv9X+MFQ==", + "dev": true, + "license": "MIT", + "dependencies": { + "available-typed-arrays": "^1.0.7", + "call-bind": "^1.0.8", + "for-each": "^0.3.3", + "gopd": "^1.2.0", + "has-proto": "^1.2.0", + "is-typed-array": "^1.1.15", + "reflect.getprototypeof": "^1.0.9" + }, + "engines": { + "node": ">= 0.4" + }, + "funding": { + "url": "https://github.com/sponsors/ljharb" + } + }, + "node_modules/typed-array-length": { + "version": "1.0.7", + "resolved": "https://registry.npmjs.org/typed-array-length/-/typed-array-length-1.0.7.tgz", + "integrity": "sha512-3KS2b+kL7fsuk/eJZ7EQdnEmQoaho/r6KUef7hxvltNA5DR8NAUM+8wJMbJyZ4G9/7i3v5zPBIMN5aybAh2/Jg==", + "dev": true, + "license": "MIT", + "dependencies": { + "call-bind": "^1.0.7", + "for-each": "^0.3.3", + "gopd": "^1.0.1", + "is-typed-array": "^1.1.13", + "possible-typed-array-names": "^1.0.0", + "reflect.getprototypeof": "^1.0.6" + }, + "engines": { + "node": ">= 0.4" + }, + "funding": { + "url": "https://github.com/sponsors/ljharb" + } + }, + "node_modules/typescript": { + "version": "5.8.2", + "resolved": "https://registry.npmjs.org/typescript/-/typescript-5.8.2.tgz", + "integrity": "sha512-aJn6wq13/afZp/jT9QZmwEjDqqvSGp1VT5GVg+f/t6/oVyrgXM6BY1h9BRh/O5p3PlUPAe+WuiEZOmb/49RqoQ==", + "dev": true, + "license": "Apache-2.0", + "peer": true, + "bin": { + "tsc": "bin/tsc", + "tsserver": "bin/tsserver" + }, + "engines": { + "node": ">=14.17" + } + }, + "node_modules/uglify-js": { + "version": "3.19.3", + "resolved": "https://registry.npmjs.org/uglify-js/-/uglify-js-3.19.3.tgz", + "integrity": "sha512-v3Xu+yuwBXisp6QYTcH4UbH+xYJXqnq2m/LtQVWKWzYc1iehYnLixoQDN9FH6/j9/oybfd6W9Ghwkl8+UMKTKQ==", + "dev": true, + "license": "BSD-2-Clause", + "bin": { + "uglifyjs": "bin/uglifyjs" + }, + "engines": { + "node": ">=0.8.0" + } + }, + "node_modules/unbox-primitive": { + "version": "1.1.0", + "resolved": "https://registry.npmjs.org/unbox-primitive/-/unbox-primitive-1.1.0.tgz", + "integrity": "sha512-nWJ91DjeOkej/TA8pXQ3myruKpKEYgqvpw9lz4OPHj/NWFNluYrjbz9j01CJ8yKQd2g4jFoOkINCTW2I5LEEyw==", + "dev": true, + "license": "MIT", + "dependencies": { + "call-bound": "^1.0.3", + "has-bigints": "^1.0.2", + "has-symbols": "^1.1.0", + "which-boxed-primitive": "^1.1.1" + }, + "engines": { + "node": ">= 0.4" + }, + "funding": { + "url": "https://github.com/sponsors/ljharb" + } + }, + "node_modules/undici-types": { + "version": "6.20.0", + "resolved": "https://registry.npmjs.org/undici-types/-/undici-types-6.20.0.tgz", + "integrity": "sha512-Ny6QZ2Nju20vw1SRHe3d9jVu6gJ+4e3+MMpqu7pqE5HT6WsTSlce++GQmK5UXS8mzV8DSYHrQH+Xrf2jVcuKNg==", + "dev": true, + "license": "MIT" + }, + "node_modules/update-browserslist-db": { + "version": "1.1.3", + "resolved": "https://registry.npmjs.org/update-browserslist-db/-/update-browserslist-db-1.1.3.tgz", + "integrity": "sha512-UxhIZQ+QInVdunkDAaiazvvT/+fXL5Osr0JZlJulepYu6Jd7qJtDZjlur0emRlT71EN3ScPoE7gvsuIKKNavKw==", + "dev": true, + "funding": [ + { + "type": "opencollective", + "url": "https://opencollective.com/browserslist" + }, + { + "type": "tidelift", + "url": "https://tidelift.com/funding/github/npm/browserslist" + }, + { + "type": "github", + "url": "https://github.com/sponsors/ai" + } + ], + "license": "MIT", + "dependencies": { + "escalade": "^3.2.0", + "picocolors": "^1.1.1" + }, + "bin": { + "update-browserslist-db": "cli.js" + }, + "peerDependencies": { + "browserslist": ">= 4.21.0" + } + }, + "node_modules/uri-js": { + "version": "4.4.1", + "resolved": "https://registry.npmjs.org/uri-js/-/uri-js-4.4.1.tgz", + "integrity": "sha512-7rKUyy33Q1yc98pQ1DAmLtwX109F7TIfWlW1Ydo8Wl1ii1SeHieeh0HHfPeL2fMXK6z0s8ecKs9frCuLJvndBg==", + "dev": true, + "license": "BSD-2-Clause", + "dependencies": { + "punycode": "^2.1.0" + } + }, + "node_modules/util-deprecate": { + "version": "1.0.2", + "resolved": "https://registry.npmjs.org/util-deprecate/-/util-deprecate-1.0.2.tgz", + "integrity": "sha512-EPD5q1uXyFxJpCrLnCc1nHnq3gOa6DZBocAIiI2TaSCA7VCJ1UJDMagCzIkXNsUYfD1daK//LTEQ8xiIbrHtcw==", + "license": "MIT" + }, + "node_modules/v8-to-istanbul": { + "version": "9.3.0", + "resolved": "https://registry.npmjs.org/v8-to-istanbul/-/v8-to-istanbul-9.3.0.tgz", + "integrity": "sha512-kiGUalWN+rgBJ/1OHZsBtU4rXZOfj/7rKQxULKlIzwzQSvMJUUNgPwJEEh7gU6xEVxC0ahoOBvN2YI8GH6FNgA==", + "dev": true, + "license": "ISC", + "dependencies": { + "@jridgewell/trace-mapping": "^0.3.12", + "@types/istanbul-lib-coverage": "^2.0.1", + "convert-source-map": "^2.0.0" + }, + "engines": { + "node": ">=10.12.0" + } + }, + "node_modules/validate-npm-package-license": { + "version": "3.0.4", + "resolved": "https://registry.npmjs.org/validate-npm-package-license/-/validate-npm-package-license-3.0.4.tgz", + "integrity": "sha512-DpKm2Ui/xN7/HQKCtpZxoRWBhZ9Z0kqtygG8XCgNQ8ZlDnxuQmWhj566j8fN4Cu3/JmbhsDo7fcAJq4s9h27Ew==", + "dev": true, + "license": "Apache-2.0", + "dependencies": { + "spdx-correct": "^3.0.0", + "spdx-expression-parse": "^3.0.0" + } + }, + "node_modules/walker": { + "version": "1.0.8", + "resolved": "https://registry.npmjs.org/walker/-/walker-1.0.8.tgz", + "integrity": "sha512-ts/8E8l5b7kY0vlWLewOkDXMmPdLcVV4GmOQLyxuSswIJsweeFZtAsMF7k1Nszz+TYBQrlYRmzOnr398y1JemQ==", + "dev": true, + "license": "Apache-2.0", + "dependencies": { + "makeerror": "1.0.12" + } + }, + "node_modules/wcwidth": { + "version": "1.0.1", + "resolved": "https://registry.npmjs.org/wcwidth/-/wcwidth-1.0.1.tgz", + "integrity": "sha512-XHPEwS0q6TaxcvG85+8EYkbiCux2XtWG2mkc47Ng2A77BQu9+DqIOJldST4HgPkuea7dvKSj5VgX3P1d4rW8Tg==", + "dev": true, + "license": "MIT", + "dependencies": { + "defaults": "^1.0.3" + } + }, + "node_modules/which": { + "version": "5.0.0", + "resolved": "https://registry.npmjs.org/which/-/which-5.0.0.tgz", + "integrity": "sha512-JEdGzHwwkrbWoGOlIHqQ5gtprKGOenpDHpxE9zVR1bWbOtYRyPPHMe9FaP6x61CmNaTThSkb0DAJte5jD+DmzQ==", + "license": "ISC", + "dependencies": { + "isexe": "^3.1.1" + }, + "bin": { + "node-which": "bin/which.js" + }, + "engines": { + "node": "^18.17.0 || >=20.5.0" + } + }, + "node_modules/which-boxed-primitive": { + "version": "1.1.1", + "resolved": "https://registry.npmjs.org/which-boxed-primitive/-/which-boxed-primitive-1.1.1.tgz", + "integrity": "sha512-TbX3mj8n0odCBFVlY8AxkqcHASw3L60jIuF8jFP78az3C2YhmGvqbHBpAjTRH2/xqYunrJ9g1jSyjCjpoWzIAA==", + "dev": true, + "license": "MIT", + "dependencies": { + "is-bigint": "^1.1.0", + "is-boolean-object": "^1.2.1", + "is-number-object": "^1.1.1", + "is-string": "^1.1.1", + "is-symbol": "^1.1.1" + }, + "engines": { + "node": ">= 0.4" + }, + "funding": { + "url": "https://github.com/sponsors/ljharb" + } + }, + "node_modules/which-builtin-type": { + "version": "1.2.1", + "resolved": "https://registry.npmjs.org/which-builtin-type/-/which-builtin-type-1.2.1.tgz", + "integrity": "sha512-6iBczoX+kDQ7a3+YJBnh3T+KZRxM/iYNPXicqk66/Qfm1b93iu+yOImkg0zHbj5LNOcNv1TEADiZ0xa34B4q6Q==", + "dev": true, + "license": "MIT", + "dependencies": { + "call-bound": "^1.0.2", + "function.prototype.name": "^1.1.6", + "has-tostringtag": "^1.0.2", + "is-async-function": "^2.0.0", + "is-date-object": "^1.1.0", + "is-finalizationregistry": "^1.1.0", + "is-generator-function": "^1.0.10", + "is-regex": "^1.2.1", + "is-weakref": "^1.0.2", + "isarray": "^2.0.5", + "which-boxed-primitive": "^1.1.0", + "which-collection": "^1.0.2", + "which-typed-array": "^1.1.16" + }, + "engines": { + "node": ">= 0.4" + }, + "funding": { + "url": "https://github.com/sponsors/ljharb" + } + }, + "node_modules/which-collection": { + "version": "1.0.2", + "resolved": "https://registry.npmjs.org/which-collection/-/which-collection-1.0.2.tgz", + "integrity": "sha512-K4jVyjnBdgvc86Y6BkaLZEN933SwYOuBFkdmBu9ZfkcAbdVbpITnDmjvZ/aQjRXQrv5EPkTnD1s39GiiqbngCw==", + "dev": true, + "license": "MIT", + "dependencies": { + "is-map": "^2.0.3", + "is-set": "^2.0.3", + "is-weakmap": "^2.0.2", + "is-weakset": "^2.0.3" + }, + "engines": { + "node": ">= 0.4" + }, + "funding": { + "url": "https://github.com/sponsors/ljharb" + } + }, + "node_modules/which-typed-array": { + "version": "1.1.19", + "resolved": "https://registry.npmjs.org/which-typed-array/-/which-typed-array-1.1.19.tgz", + "integrity": "sha512-rEvr90Bck4WZt9HHFC4DJMsjvu7x+r6bImz0/BrbWb7A2djJ8hnZMrWnHo9F8ssv0OMErasDhftrfROTyqSDrw==", + "dev": true, + "license": "MIT", + "dependencies": { + "available-typed-arrays": "^1.0.7", + "call-bind": "^1.0.8", + "call-bound": "^1.0.4", + "for-each": "^0.3.5", + "get-proto": "^1.0.1", + "gopd": "^1.2.0", + "has-tostringtag": "^1.0.2" + }, + "engines": { + "node": ">= 0.4" + }, + "funding": { + "url": "https://github.com/sponsors/ljharb" + } + }, + "node_modules/word-wrap": { + "version": "1.2.5", + "resolved": "https://registry.npmjs.org/word-wrap/-/word-wrap-1.2.5.tgz", + "integrity": "sha512-BN22B5eaMMI9UMtjrGd5g5eCYPpCPDUy0FJXbYsaT5zYxjFOckS53SQDE3pWkVoWpHXVb3BrYcEN4Twa55B5cA==", + "dev": true, + "license": "MIT", + "engines": { + "node": ">=0.10.0" + } + }, + "node_modules/wrap-ansi": { + "version": "7.0.0", + "resolved": "https://registry.npmjs.org/wrap-ansi/-/wrap-ansi-7.0.0.tgz", + "integrity": "sha512-YVGIj2kamLSTxw6NsZjoBxfSwsn0ycdesmc4p+Q21c5zPuZ1pl+NfxVdxPtdHvmNVOQ6XSYG4AUtyt/Fi7D16Q==", + "dev": true, + "license": "MIT", + "dependencies": { + "ansi-styles": "^4.0.0", + "string-width": "^4.1.0", + "strip-ansi": "^6.0.0" + }, + "engines": { + "node": ">=10" + }, + "funding": { + "url": "https://github.com/chalk/wrap-ansi?sponsor=1" + } + }, + "node_modules/wrappy": { + "version": "1.0.2", + "resolved": "https://registry.npmjs.org/wrappy/-/wrappy-1.0.2.tgz", + "integrity": "sha512-l4Sp/DRseor9wL6EvV2+TuQn63dMkPjZ/sp9XkghTEbV9KlPS1xUsZ3u7/IQO4wxtcFB4bgpQPRcR3QCvezPcQ==", + "dev": true, + "license": "ISC" + }, + "node_modules/write-file-atomic": { + "version": "4.0.2", + "resolved": "https://registry.npmjs.org/write-file-atomic/-/write-file-atomic-4.0.2.tgz", + "integrity": "sha512-7KxauUdBmSdWnmpaGFg+ppNjKF8uNLry8LyzjauQDOVONfFLNKrKvQOxZ/VuTIcS/gge/YNahf5RIIQWTSarlg==", + "dev": true, + "license": "ISC", + "dependencies": { + "imurmurhash": "^0.1.4", + "signal-exit": "^3.0.7" + }, + "engines": { + "node": "^12.13.0 || ^14.15.0 || >=16.0.0" + } + }, + "node_modules/xmlbuilder": { + "version": "15.1.1", + "resolved": "https://registry.npmjs.org/xmlbuilder/-/xmlbuilder-15.1.1.tgz", + "integrity": "sha512-yMqGBqtXyeN1e3TGYvgNgDVZ3j84W4cwkOXQswghol6APgZWaff9lnbvN7MHYJOiXsvGPXtjTYJEiC9J2wv9Eg==", + "dev": true, + "license": "MIT", + "engines": { + "node": ">=8.0" + } + }, + "node_modules/y18n": { + "version": "5.0.8", + "resolved": "https://registry.npmjs.org/y18n/-/y18n-5.0.8.tgz", + "integrity": "sha512-0pfFzegeDWJHJIAmTLRP2DwHjdF5s7jo9tuztdQxAhINCdvS+3nGINqPd00AphqJR/0LhANUS6/+7SCb98YOfA==", + "dev": true, + "license": "ISC", + "engines": { + "node": ">=10" + } + }, + "node_modules/yallist": { + "version": "3.1.1", + "resolved": "https://registry.npmjs.org/yallist/-/yallist-3.1.1.tgz", + "integrity": "sha512-a4UGQaWPH59mOXUYnAG2ewncQS4i4F43Tv3JoAM+s2VDAmS9NsK8GpDMLrCHPksFT7h3K6TOoUNn2pb7RoXx4g==", + "dev": true, + "license": "ISC" + }, + "node_modules/yargs": { + "version": "17.7.2", + "resolved": "https://registry.npmjs.org/yargs/-/yargs-17.7.2.tgz", + "integrity": "sha512-7dSzzRQ++CKnNI/krKnYRV7JKKPUXMEh61soaHKg9mrWEhzFWhFnxPxGl+69cD1Ou63C13NUPCnmIcrvqCuM6w==", + "dev": true, + "license": "MIT", + "dependencies": { + "cliui": "^8.0.1", + "escalade": "^3.1.1", + "get-caller-file": "^2.0.5", + "require-directory": "^2.1.1", + "string-width": "^4.2.3", + "y18n": "^5.0.5", + "yargs-parser": "^21.1.1" + }, + "engines": { + "node": ">=12" + } + }, + "node_modules/yargs-parser": { + "version": "21.1.1", + "resolved": "https://registry.npmjs.org/yargs-parser/-/yargs-parser-21.1.1.tgz", + "integrity": "sha512-tVpsJW7DdjecAiFpbIB1e3qxIQsE6NoPc5/eTdrbbIC4h0LVsWhnoa3g+m2HclBIujHzsxZ4VJVA+GUuc2/LBw==", + "dev": true, + "license": "ISC", + "engines": { + "node": ">=12" + } + }, + "node_modules/yocto-queue": { + "version": "0.1.0", + "resolved": "https://registry.npmjs.org/yocto-queue/-/yocto-queue-0.1.0.tgz", + "integrity": "sha512-rVksvsnNCdJ/ohGc6xgPwyN8eheCxsiLM8mxuE/t/mOVqJewPuO1miLpTHQiRgTKCLexL4MeAFVagts7HmNZ2Q==", + "dev": true, + "license": "MIT", + "engines": { + "node": ">=10" + }, + "funding": { + "url": "https://github.com/sponsors/sindresorhus" + } + } + } +} diff --git a/package.json b/package.json new file mode 100644 index 0000000000..4bc8aca88e --- /dev/null +++ b/package.json @@ -0,0 +1,51 @@ +{ + "name": "guida", + "version": "1.0.0-alpha", + "description": "Guida is a functional programming language that builds upon the solid foundation of Elm, offering backward compatibility with all existing Elm 0.19.1 projects", + "author": "Decio Ferreira", + "license": "BSD-3-Clause", + "main": "lib/node.js", + "browser": "lib/browser.js", + "bin": { + "guida": "bin/index.js" + }, + "scripts": { + "build": "npm-run-all --sequential build:*", + "build:node": "./scripts/build.sh node", + "build:browser": "./scripts/build.sh browser", + "build:bin": "./scripts/build.sh bin", + "watch": "onchange \"src/**/*.elm\" -- npm run build:bin", + "test": "npm-run-all --sequential test:*", + "test:eslint": "eslint", + "test:elm-format-validate": "elm-format . --validate", + "test:jest": "jest", + "test:elm": "elm-test", + "test:elm-review": "elm-review", + "elm-format": "elm-format . --yes", + "prepare": "npm run build" + }, + "dependencies": { + "adm-zip": "^0.5.16", + "form-data": "^4.0.2", + "indexeddb-fs": "^2.1.5", + "jszip": "^3.10.1", + "mock-xmlhttprequest": "^8.4.1", + "tmp": "^0.2.3", + "which": "^5.0.0" + }, + "devDependencies": { + "@eslint/js": "^9.23.0", + "elm": "^0.19.1-6", + "elm-format": "^0.8.7", + "elm-review": "^2.13.2", + "elm-test": "^0.19.1-revision15", + "eslint": "^9.23.0", + "eslint-plugin-jest": "^28.11.0", + "globals": "^16.0.0", + "guida": "^0.3.0-alpha", + "jest": "^29.7.0", + "npm-run-all": "^4.1.5", + "onchange": "^7.1.0", + "uglify-js": "^3.19.3" + } +} \ No newline at end of file diff --git a/reactor/assets/favicon.ico b/reactor/assets/favicon.ico deleted file mode 100644 index 41edb81039..0000000000 Binary files a/reactor/assets/favicon.ico and /dev/null differ diff --git a/reactor/assets/source-code-pro.ttf b/reactor/assets/source-code-pro.ttf deleted file mode 100644 index 268a2e4322..0000000000 Binary files a/reactor/assets/source-code-pro.ttf and /dev/null differ diff --git a/reactor/assets/source-sans-pro.ttf b/reactor/assets/source-sans-pro.ttf deleted file mode 100644 index 950ff8bd4b..0000000000 Binary files a/reactor/assets/source-sans-pro.ttf and /dev/null differ diff --git a/reactor/assets/styles.css b/reactor/assets/styles.css deleted file mode 100644 index e6c18ca174..0000000000 --- a/reactor/assets/styles.css +++ /dev/null @@ -1,157 +0,0 @@ -@charset "UTF-8"; - - -/* FONTS */ - -@font-face { - font-family: 'Source Code Pro'; - font-style: normal; - font-weight: 400; - src: local('Source Code Pro'), local('SourceCodePro-Regular'), url(/_elm/source-code-pro.ttf) format('truetype'); -} - -@font-face { - font-family: 'Source Sans Pro'; - font-style: normal; - font-weight: 400; - src: local('Source Sans Pro'), local('SourceSansPro-Regular'), url(/_elm/source-sans-pro.ttf) format('truetype'); -} - - -/* GENERIC STUFF */ - -html, head, body { - margin: 0; - height: 100%; -} - -body { - font-family: 'Source Sans Pro', 'Trebuchet MS', 'Lucida Grande', 'Bitstream Vera Sans', 'Helvetica Neue', sans-serif; - color: #293c4b; -} - -a { - color: #60B5CC; - text-decoration: none; -} - -a:hover { - text-decoration: underline; -} - - -/* INDEX */ - -.header { - width: 100%; - background-color: #60B5CC; - height: 8px; -} - -.content { - width: 960px; - margin-left: auto; - margin-right: auto; -} - - -/* COLUMNS */ - -.left-column { - float: left; - width: 600px; - padding-bottom: 80px; -} - -.right-column { - float: right; - width: 300px; - padding-bottom: 80px; -} - - -/* BOXES */ - -.box { - border: 1px solid #c7c7c7; - border-radius: 5px; - margin-bottom: 40px; -} - -.box-header { - display: block; - overflow: hidden; - padding: 7px 12px; - background-color: #fafafa; - text-align: center; - border-radius: 5px; -} - -.box-item { - display: block; - overflow: hidden; - padding: 7px 12px; - border-top: 1px solid #e1e1e1; -} - -.box-footer { - display: block; - overflow: hidden; - padding: 2px 12px; - border-top: 1px solid #e1e1e1; - text-align: center; - background-color: #fafafa; - height: 16px; -} - - -/* ICONS */ - -.icon { - display: inline-block; - vertical-align: middle; - padding-right: 0.5em; -} - - -/* PAGES */ - -.page-name { - float: left; -} - -.page-size { - float: right; - color: #293c4b; -} - -.page-size:hover { - color: #60B5CC; -} - - -/* WAITING */ - -.waiting { - width: 100%; - height: 100%; - display: flex; - flex-direction: column; - justify-content: center; - align-items: center; - color: #9A9A9A; -} - - -/* NOT FOUND */ - -.not-found { - width: 100%; - height: 100%; - display: flex; - flex-direction: column; - justify-content: center; - align-items: center; - background-color: #F5F5F5; - color: #9A9A9A; -} diff --git a/reactor/check.py b/reactor/check.py deleted file mode 100755 index 9aced8b253..0000000000 --- a/reactor/check.py +++ /dev/null @@ -1,48 +0,0 @@ -#!/usr/bin/env python - -import os -import sys - - -## FIGURE OUT NEW MODIFICATION TIME - -def mostRecentModification(directory): - mostRecent = 0 - - for dirpath, dirs, files in os.walk(directory): - for f in files: - lastModified = os.path.getmtime(dirpath + '/' + f) - mostRecent = max(int(lastModified), mostRecent) - - return mostRecent - - -srcTime = mostRecentModification('ui/src') -assetTime = mostRecentModification('ui/assets') -mostRecent = max(srcTime, assetTime) - - -## FIGURE OUT OLD MODIFICATION TIME - -with open('ui/last-modified', 'a') as handle: - pass - - -prevMostRecent = 0 - - -with open('ui/last-modified', 'r+') as handle: - line = handle.read() - prevMostRecent = int(line) if line else 0 - - -## TOUCH FILES IF NECESSARY - -if mostRecent > prevMostRecent: - print "+------------------------------------------------------------+" - print "| Some ui/ code changed. Touching src/Reactor/StaticFiles.hs |" - print "| to trigger a recompilation of the Template Haskell stuff. |" - print "+------------------------------------------------------------+" - os.utime('src/Reactor/StaticFiles.hs', None) - with open('ui/last-modified', 'w') as handle: - handle.write(str(mostRecent)) diff --git a/reactor/elm.json b/reactor/elm.json deleted file mode 100644 index 3a8a772090..0000000000 --- a/reactor/elm.json +++ /dev/null @@ -1,31 +0,0 @@ -{ - "type": "application", - "source-directories": [ - "src" - ], - "elm-version": "0.19.1", - "dependencies": { - "direct": { - "elm/browser": "1.0.1", - "elm/core": "1.0.2", - "elm/html": "1.0.0", - "elm/http": "2.0.0", - "elm/json": "1.1.2", - "elm/project-metadata-utils": "1.0.0", - "elm/svg": "1.0.1", - "elm-explorations/markdown": "1.0.0" - }, - "indirect": { - "elm/bytes": "1.0.7", - "elm/file": "1.0.1", - "elm/parser": "1.1.0", - "elm/time": "1.0.0", - "elm/url": "1.0.0", - "elm/virtual-dom": "1.0.2" - } - }, - "test-dependencies": { - "direct": {}, - "indirect": {} - } -} diff --git a/reactor/src/Deps.elm b/reactor/src/Deps.elm deleted file mode 100644 index 50310dfdad..0000000000 --- a/reactor/src/Deps.elm +++ /dev/null @@ -1,1210 +0,0 @@ -module Deps exposing (main) - - -import Browser -import Browser.Dom as Dom -import Dict exposing (Dict) -import Elm.Constraint as Constraint exposing (Constraint) -import Html exposing (..) -import Html.Attributes exposing (..) -import Html.Events exposing (..) -import Html.Keyed as Keyed -import Html.Lazy exposing (..) -import Http -import Json.Decode as D -import Json.Encode as E -import Svg -import Svg.Attributes as S -import Task - - - --- MAIN - - -main = - Browser.document - { init = init - , view = view - , update = update - , subscriptions = \_ -> Sub.none - } - - - --- MODEL - - -type alias Model = - { status : Status - , id : Int - -- queries - , search : Search - , registry : Registry - -- history - , past : List Change - , future : List Change - , origin : Origin - } - - - --- STATUS - - -type Status - = Failure Checkpoint (List Change) - | Waiting Checkpoint (List Change) - | Success Checkpoint - - -type alias Checkpoint = - { direct : Dict String Bounds - , indirect : Dict String Bounds - } - - -type Bounds - = New Version NewBounds - | Old Version Version OldBounds - - -type NewBounds - = NAny - | NCustom Constraint - - -type OldBounds - = OLocked - | OPatch - | OMinor - | OMajor - | OAny - | OCustom Constraint - - - --- CHANGES - - -type Change - = MassLock - | MassPatch - | MassMinor - | MassMajor - | AddDirect String - | TweakOldDirect String OldBounds - | TweakNewDirect String NewBounds - | TweakOldIndirect String OldBounds - | TweakNewIndirect String NewBounds - | DeleteDirect String - | DeleteIndirect String - - - --- PREVIEW - - -type alias Preview = - { direct : Dict String PBounds - , indirect : Dict String PBounds - } - - -type PBounds - = PNew (Maybe Version) NewBounds - | POld Version Version OldBounds - - -toPreview : Origin -> Checkpoint -> List Change -> Preview -toPreview origin checkpoint changes = - let - toPreviewBounds _ bounds = - case bounds of - New vsn nb -> PNew (Just vsn) nb - Old old new ob -> POld old new ob - - start = - { direct = Dict.map toPreviewBounds checkpoint.direct - , indirect = Dict.map toPreviewBounds checkpoint.indirect - } - in - List.foldr (step origin) start changes - - -step : Origin -> Change -> Preview -> Preview -step origin change preview = - case change of - MassLock -> - massChange OLocked preview - - MassPatch -> - massChange OPatch preview - - MassMinor -> - massChange OMinor preview - - MassMajor -> - massChange OMajor preview - - AddDirect pkg -> - let - pBound = - case Dict.get pkg origin.direct of - Just vsn -> POld vsn vsn OLocked - Nothing -> - case Dict.get pkg origin.indirect of - Just vsn -> POld vsn vsn OLocked - Nothing -> PNew Nothing NAny - in - { direct = Dict.insert pkg pBound preview.direct - , indirect = Dict.remove pkg preview.indirect - } - - TweakOldDirect pkg oldBounds -> - { direct = Dict.update pkg (alterOld oldBounds) preview.direct - , indirect = preview.indirect - } - - TweakNewDirect pkg newBounds -> - { direct = Dict.update pkg (alterNew newBounds) preview.direct - , indirect = preview.indirect - } - - TweakOldIndirect pkg oldBounds -> - { direct = preview.direct - , indirect = Dict.update pkg (alterOld oldBounds) preview.indirect - } - - TweakNewIndirect pkg newBounds -> - { direct = preview.direct - , indirect = Dict.update pkg (alterNew newBounds) preview.indirect - } - - DeleteDirect pkg -> - { direct = Dict.remove pkg preview.direct - , indirect = preview.indirect - } - - DeleteIndirect pkg -> - { direct = preview.direct - , indirect = Dict.remove pkg preview.indirect - } - - -massChange : OldBounds -> Preview -> Preview -massChange oldBounds preview = - let - changeBounds _ bounds = - case bounds of - PNew vsn newBounds -> PNew vsn newBounds - POld old new _ -> POld old new oldBounds - in - { direct = Dict.map changeBounds preview.direct - , indirect = Dict.map changeBounds preview.indirect - } - - -alterOld : OldBounds -> Maybe PBounds -> Maybe PBounds -alterOld ob maybeBounds = - case maybeBounds of - Nothing -> - Nothing - - Just bounds -> - case bounds of - PNew vsn nb -> Just (PNew vsn nb) - POld old new _ -> Just (POld old new ob) - - -alterNew : NewBounds -> Maybe PBounds -> Maybe PBounds -alterNew nb maybeBounds = - case maybeBounds of - Nothing -> - Nothing - - Just bounds -> - case bounds of - PNew vsn _ -> Just (PNew vsn nb) - POld old new ob -> Just (POld old new ob) - - - --- INIT - - -init : () -> (Model, Cmd Msg) -init () = - let - origin = startTODO - chkp = toInitialCheckpoint origin - in - await chkp [] - { status = Waiting chkp [] - , id = 0 - , search = { query = "", focus = Nothing } - , registry = registryTODO - , past = [] - , future = [] - , origin = origin - } - - -type alias Origin = - { direct : Dict String Version - , indirect : Dict String Version - } - - -startTODO : Origin -startTODO = - { direct = - Dict.fromList - [ ("elm/browser", Version 1 0 1) - , ("elm/core", Version 1 0 2) - , ("elm/html", Version 1 0 0) - , ("elm/http", Version 2 0 0) - , ("elm/json", Version 1 1 2) - , ("elm/project-metadata-utils", Version 1 0 0) - , ("elm/svg", Version 1 0 1) - , ("elm-explorations/markdown", Version 1 0 0) - ] - , indirect = - Dict.fromList - [ ("elm/parser", Version 1 1 0) - , ("elm/time", Version 1 0 0) - , ("elm/url", Version 1 0 0) - , ("elm/virtual-dom", Version 1 0 2) - ] - } - - - --- CHECKPOINTS - - -toInitialCheckpoint : Origin -> Checkpoint -toInitialCheckpoint origin = - { direct = Dict.map (\_ v -> Old v v OLocked) origin.direct - , indirect = Dict.map (\_ v -> Old v v OLocked) origin.indirect - } - - -toCheckpoint : Dict String Version -> Preview -> Maybe Checkpoint -toCheckpoint solution preview = - let - direct = Dict.foldr (addBound solution) Dict.empty preview.direct - indirect = Dict.foldr (addBound solution) Dict.empty preview.indirect - in - if Dict.size direct == Dict.size preview.direct then - Just (Checkpoint direct indirect) - else - Nothing - - -addBound : Dict String Version -> String -> PBounds -> Dict String Bounds -> Dict String Bounds -addBound solution pkg bounds dict = - case Dict.get pkg solution of - Nothing -> - dict - - Just new -> - case bounds of - PNew _ newBounds -> - Dict.insert pkg (New new newBounds) dict - - POld old _ oldBounds -> - Dict.insert pkg (Old old new oldBounds) dict - - - --- UPDATE - - -type Msg - = NoOp - | Commit Change - | Undo - | Redo - | GotSolution Int (Result Http.Error (Dict String Version)) - | SearchTouched SearchMsg - - -update : Msg -> Model -> (Model, Cmd Msg) -update msg model = - case Debug.log "msg" msg of - NoOp -> - ( model, Cmd.none ) - - Commit latest -> - let (checkpoint, changes) = getCheckpoint model.status in - await checkpoint (latest::changes) { model | future = [] } - - Undo -> - case getCheckpoint model.status of - (checkpoint, latest :: previous) -> - await checkpoint previous { model | future = latest :: model.future } - - (_, []) -> - case model.past of - [] -> ( model, Cmd.none ) - - latest :: previous -> - await (toInitialCheckpoint model.origin) previous - { model | past = [], future = latest :: model.future } - - Redo -> - case model.future of - [] -> - ( model, Cmd.none ) - - next :: nexterer -> - let (checkpoint, changes) = getCheckpoint model.status in - await checkpoint (next::changes) { model | future = nexterer } - - GotSolution id result -> - if model.id /= id then - ( model, Cmd.none ) - else - let - (oldCheckpoint, changes) = getCheckpoint model.status - in - case result of - Err _ -> - ( { model | status = Failure oldCheckpoint changes }, Cmd.none ) - - Ok solution -> - case toCheckpoint solution (toPreview model.origin oldCheckpoint changes) of - Nothing -> - ( { model | status = Failure oldCheckpoint changes } - , Cmd.none - ) - - Just newCheckpoint -> - ( { model - | status = Success newCheckpoint - , past = changes ++ model.past - } - , Cmd.none - ) - - SearchTouched searchMsg -> - case updateSearch model.registry searchMsg model.search of - SNone -> - ( model, Cmd.none ) - - SUpdate newSearch -> - ( { model | search = newSearch } - , Cmd.none - ) - - SManualBlur newSearch -> - ( { model | search = newSearch } - , Task.attempt (\_ -> NoOp) (Dom.blur searchDepsID) - ) - - SAdd name -> - let (checkpoint, changes) = getCheckpoint model.status in - await checkpoint (AddDirect name :: changes) - { model - | search = { query = "", focus = Nothing } - , future = [] - } - - -getCheckpoint : Status -> (Checkpoint, List Change) -getCheckpoint status = - case status of - Failure chkp cs -> (chkp, cs) - Waiting chkp cs -> (chkp, cs) - Success chkp -> (chkp, []) - - -await : Checkpoint -> List Change -> Model -> (Model, Cmd Msg) -await checkpoint changes model = - let - id = model.id + 1 - preview = toPreview model.origin checkpoint changes - in - ( - { model - | status = Waiting checkpoint changes - , id = id - } - , - Http.post - { url = "/elm-stuff/solve" - , body = - Http.jsonBody <| - E.object - [ ("direct", E.dict identity encodeConstraint preview.direct) - , ("indirect", E.dict identity encodeConstraint preview.indirect) - ] - , expect = Http.expectJson (GotSolution id) solutionDecoder - } - ) - - - --- VIEW - - -view : Model -> Browser.Document Msg -view model = - { title = "elm.json" - , body = - [ span - [ style "width" "calc(100% - 500px - 2em)" - , style "position" "fixed" - , style "top" "0" - , style "left" "0" - , style "bottom" "0" - , style "overflow-x" "hidden" - , style "overflow-y" "scroll" - , style "filter" "blur(4px)" - , style "white-space" "pre" - , style "font-family" "monospace" - ] - [ text elmJson - ] - , viewEditPanel model - ] - } - - -viewEditPanel : Model -> Html Msg -viewEditPanel model = - div - [ style "width" "500px" - , style "position" "fixed" - , style "top" "0" - , style "right" "0" - , style "bottom" "0" - , style "overflow-y" "scroll" - , style "background-color" "white" - , style "padding" "1em" - ] - [ node "style" [] [ text styles ] - , div - [ style "display" "flex" - , style "justify-content" "space-between" - ] - [ viewMassUpdates - , lazy3 viewUndoRedo model.status model.past model.future - ] - , div - [ style "display" "flex" - , style "justify-content" "space-between" - , style "align-items" "center" - ] - [ h2 [] [ text "Dependencies" ] - , Html.map SearchTouched <| - lazy4 viewSearch searchDepsID "Package Search" model.registry model.search - ] - , lazy2 viewStatus model.origin model.status - ] - - -viewMassUpdates : Html Msg -viewMassUpdates = - div [] - [ text "Mass Updates: " - , activeButton (Commit MassLock ) (text "LOCK") - , activeButton (Commit MassPatch) (text "PATCH") - , activeButton (Commit MassMinor) (text "MINOR") - , activeButton (Commit MassMajor) (text "MAJOR") - ] - - -viewUndoRedo : Status -> List Change -> List Change -> Html Msg -viewUndoRedo status past future = - let - hasNoPast = - List.isEmpty past && - case status of - Failure _ cs -> List.isEmpty cs - Waiting _ cs -> List.isEmpty cs - Success _ -> True - - hasNoFuture = - List.isEmpty future - in - div [] - [ if hasNoPast then inactiveButton undoIcon else activeButton Undo undoIcon - , if hasNoFuture then inactiveButton redoIcon else activeButton Redo redoIcon - ] - - -activeButton : msg -> Html msg -> Html msg -activeButton msg content = - button [ class "button", onClick msg ] [ content ] - - -inactiveButton : Html msg -> Html msg -inactiveButton content = - button [ class "button-inactive" ] [ content ] - - - --- VIEW STATUS - - -viewStatus : Origin -> Status -> Html Msg -viewStatus origin status = - let - (directs, indirects) = viewStatusRows origin status - in - div [] - [ viewTable "Direct" <| Dict.toList directs - , viewTable "Indirect" <| Dict.toList indirects - ] - - -viewStatusRows : Origin -> Status -> (Dict String (Html Msg), Dict String (Html Msg)) -viewStatusRows origin status = - case status of - Failure checkpoint changes -> - let preview = toPreview origin checkpoint changes in - ( Dict.map (lazy2 viewWaitingRow) preview.direct - , Dict.map (lazy2 viewWaitingRow) preview.indirect - ) - - Waiting checkpoint changes -> - let preview = toPreview origin checkpoint changes in - ( Dict.map (lazy2 viewWaitingRow) preview.direct - , Dict.map (lazy2 viewWaitingRow) preview.indirect - ) - - Success checkpoint -> - ( Dict.map (lazy2 viewSuccessRow) checkpoint.direct - , Dict.map (lazy2 viewSuccessRow) checkpoint.indirect - ) - - -viewSuccessRow : String -> Bounds -> Html Msg -viewSuccessRow pkg bounds = - case bounds of - New version newBounds -> - viewRow pkg (RowNew version) - - Old old new oldBounds -> - viewRow pkg (RowOld old new) - - -viewWaitingRow : String -> PBounds -> Html Msg -viewWaitingRow pkg bounds = - case bounds of - PNew vsn newBounds -> - viewRow pkg (RowNewGuess vsn) - - POld old new oldBounds -> - viewRow pkg (RowOldGuess old new) - - - --- VIEW TABLE - - -viewTable : String -> List (String, Html Msg) -> Html Msg -viewTable title rows = - table [ style "padding-bottom" "1em" ] - [ viewColgroup - , thead [] [ tr [] [ td [ class "table-title" ] [ text title ] ] ] - , Keyed.node "tbody" [] rows - ] - - -viewColgroup : Html msg -viewColgroup = - colgroup [] - [ col [ style "width" "350px" ] [] - , col [ style "width" "50px" ] [] - , col [ style "width" "50px" ] [] - , col [ style "width" "50px" ] [] - ] - - -type RowInfo - = RowNew Version - | RowOld Version Version - | RowNewGuess (Maybe Version) - | RowOldGuess Version Version - - -viewRow : String -> RowInfo -> Html msg -viewRow pkg info = - case info of - RowNew vsn -> - viewRowHelp pkg (text "") (text "") (viewVersion "black" vsn) - - RowNewGuess Nothing -> - viewRowHelp pkg (text "") (text "") (text "") - - RowNewGuess (Just v) -> - viewRowHelp pkg (text "") (text "") (viewVersion "#eeeeee" v) - - RowOld old new -> - if old == new - then viewRowHelp pkg (text "") (text "") (viewVersion "#cccccc" new) - else viewRowHelp pkg (viewVersion "#cccccc" old) (viewArrow "#cccccc") (viewVersion "black" new) - - RowOldGuess old new -> - if old == new - then viewRowHelp pkg (text "") (text "") (viewVersion "#eeeeee" new) - else viewRowHelp pkg (viewVersion "#eeeeee" old) (viewArrow "#eeeeee") (viewVersion "#eeeeee" new) - - -viewRowHelp : String -> Html msg -> Html msg -> Html msg -> Html msg -viewRowHelp pkg oldHtml arrowHtml newHtml = - tr [] - [ td [ style "font-family" "monospace" ] [ text pkg ] - , td [ style "text-align" "right" ] [ oldHtml ] - , td [ style "text-align" "center" ] [ arrowHtml ] - , td [ ] [ newHtml ] - ] - - -viewVersion : String -> Version -> Html msg -viewVersion color (Version x y z) = - span - [ style "font-family" "monospace" - , style "color" color - , style "transition" "color 1s" - ] - [ text (v2s x y z) - ] - - -viewArrow : String -> Html msg -viewArrow color = - span - [ style "color" color - , style "transition" "color 1s" - ] - [ text "→" - ] - - - --- REGISTRY - - -type alias Registry = Dict String (List Char) - - -toRegistry : List String -> Registry -toRegistry packages = - Dict.fromList (List.map (\n -> (n, toSearchChars n)) packages) - - -toSearchChars : String -> List Char -toSearchChars string = - String.toList (String.toLower string) - - -registryTODO : Registry -registryTODO = - toRegistry - [ "elm-explorations/test" - , "elm-explorations/markdown" - , "elm/browser" - , "elm/bytes" - , "elm/core" - , "elm/file" - , "elm/html" - , "elm/http" - , "elm/json" - , "elm/project-metadata-utils" - , "elm/svg" - , "elm/parser" - , "elm/time" - , "elm/url" - , "elm/virtual-dom" - ] - - - --- SEARCH - - -type alias Search = - { query : String - , focus : Maybe Int - } - - -type SearchMsg - = SChanged String - | SUp - | SDown - | SFocus - | SBlur - | SEscape - | SEnter - | SClickAdd - | SClickMatch String - - -type SearchNext - = SNone - | SUpdate Search - | SManualBlur Search - | SAdd String - - -updateSearch : Registry -> SearchMsg -> Search -> SearchNext -updateSearch registry msg search = - case msg of - SChanged query -> - SUpdate { query = query, focus = Just 0 } - - SUp -> - let - newFocus = Maybe.map (\n -> Basics.max 0 (n - 1)) search.focus - in - SUpdate { search | focus = newFocus } - - SDown -> - let - numMatches = List.length (getBestMatches search.query registry) - newFocus = Maybe.map (\n -> Basics.min numMatches (n + 1)) search.focus - in - SUpdate { search | focus = newFocus } - - SFocus -> - SUpdate { search | focus = Just 0 } - - SBlur -> - SUpdate { search | focus = Nothing } - - SEscape -> - SManualBlur { search | focus = Nothing } - - SEnter -> - case search.focus of - Nothing -> - SNone - - Just 0 -> - if Dict.member search.query registry - then SAdd search.query - else SNone - - Just n -> - case getMatch n (getBestMatches search.query registry) of - Just match -> SUpdate { query = match, focus = Just 0 } - Nothing -> SNone - - SClickAdd -> - if Dict.member search.query registry - then SAdd search.query - else SNone - - SClickMatch match -> - SUpdate { query = match, focus = Just 0 } - - -getMatch : Int -> List (Int, String) -> Maybe String -getMatch n matches = - case matches of - [] -> - Nothing - - (_, match) :: worseMatches -> - if n <= 0 then - Nothing - else if n == 1 then - Just match - else - getMatch (n-1) worseMatches - - - --- VIEW SEARCH - - -searchDepsID : String -searchDepsID = "search-deps" - - -searchTestID : String -searchTestID = "search-test" - - -viewSearch : String -> String -> Registry -> Search -> Html SearchMsg -viewSearch searchID ghostText registry search = - div [ style "position" "relative" ] - [ lazy3 viewSearchQuery searchID ghostText search.query - , lazy2 viewSearchAdd search.query registry - , lazy3 viewSearchMatches search.query search.focus registry - ] - - -viewSearchAdd : String -> Registry -> Html SearchMsg -viewSearchAdd query registry = - if Dict.member query registry then - activeButton SClickAdd (text "Add") - else - inactiveButton (text "Add") - - -viewSearchMatches : String -> Maybe Int -> Registry -> Html SearchMsg -viewSearchMatches query focus registry = - case focus of - Nothing -> - text "" - - Just n -> - if String.isEmpty query - then text "" - else - case getBestMatches query registry of - [] -> - text "" - - bestMatches -> - div [ class "search-matches" ] <| - List.indexedMap (viewSearchMatch (n-1)) bestMatches - - -viewSearchMatch : Int -> Int -> (Int, String) -> Html SearchMsg -viewSearchMatch target actual (_, name) = - div - [ class "search-match" - , classList [("search-match-focused", target == actual)] - , onClick (SClickMatch name) - ] - [ div [ style "padding" "0.5em 1em" ] [ text name ] - ] - - - --- VIEW SEARCH QUERY - - -viewSearchQuery : String -> String -> String -> Html SearchMsg -viewSearchQuery searchID ghostText query = - input - [ type_ "text" - , id searchID - , placeholder ghostText - , autocomplete False - , class "search-input" - , value query - , onInput SChanged - , on "keydown" keyDecoder - , onFocus SFocus - , onBlur SBlur - ] - [] - - -keyDecoder : D.Decoder SearchMsg -keyDecoder = - let - check up down enter escape value = - if value == up then - D.succeed SUp - else if value == down then - D.succeed SDown - else if value == enter then - D.succeed SEnter - else if value == escape then - D.succeed SEscape - else - D.fail "not up or down" - in - D.oneOf - [ D.field "key" D.string - |> D.andThen (check "ArrowUp" "ArrowDown" "Enter" "Escape") - , D.field "keyCode" D.int - |> D.andThen (check 38 40 13 27) - ] - - - --- MATCHES - - -getBestMatches : String -> Registry -> List (Int, String) -getBestMatches query registry = - Dict.foldl (addMatch (toSearchChars query)) [] registry - - -addMatch : List Char -> String -> List Char -> List (Int, String) -> List (Int, String) -addMatch queryChars targetName targetChars bestMatches = - case distance 0 queryChars targetChars of - Nothing -> - bestMatches - - Just dist -> - insert 4 targetName dist bestMatches - - -insert : Int -> String -> Int -> List (Int, String) -> List (Int, String) -insert limit name dist bestMatches = - if limit <= 0 then - bestMatches - else - case bestMatches of - [] -> - [ (dist, name) ] - - ((bestDist, bestName) as best) :: worseMatches -> - if dist < bestDist then - (dist, name) :: List.take (limit - 1) bestMatches - else - best :: insert (limit - 1) name dist worseMatches - - -distance : Int -> List Char -> List Char -> Maybe Int -distance dist queryChars targetChars = - case queryChars of - [] -> - case dist + List.length targetChars of - 0 -> Nothing - n -> Just n - - qc :: qcs -> - case targetChars of - [] -> - Nothing - - tc :: tcs -> - if qc == tc then - distance dist qcs tcs - else - distance (dist + 1) queryChars tcs - - - --- ICONS - - -undoIcon : Html msg -undoIcon = - icon "M255.545 8c-66.269.119-126.438 26.233-170.86 68.685L48.971 40.971C33.851 25.851 8 36.559 8 57.941V192c0 13.255 10.745 24 24 24h134.059c21.382 0 32.09-25.851 16.971-40.971l-41.75-41.75c30.864-28.899 70.801-44.907 113.23-45.273 92.398-.798 170.283 73.977 169.484 169.442C423.236 348.009 349.816 424 256 424c-41.127 0-79.997-14.678-110.63-41.556-4.743-4.161-11.906-3.908-16.368.553L89.34 422.659c-4.872 4.872-4.631 12.815.482 17.433C133.798 479.813 192.074 504 256 504c136.966 0 247.999-111.033 248-247.998C504.001 119.193 392.354 7.755 255.545 8z" - - -redoIcon : Html msg -redoIcon = - icon "M256.455 8c66.269.119 126.437 26.233 170.859 68.685l35.715-35.715C478.149 25.851 504 36.559 504 57.941V192c0 13.255-10.745 24-24 24H345.941c-21.382 0-32.09-25.851-16.971-40.971l41.75-41.75c-30.864-28.899-70.801-44.907-113.23-45.273-92.398-.798-170.283 73.977-169.484 169.442C88.764 348.009 162.184 424 256 424c41.127 0 79.997-14.678 110.629-41.556 4.743-4.161 11.906-3.908 16.368.553l39.662 39.662c4.872 4.872 4.631 12.815-.482 17.433C378.202 479.813 319.926 504 256 504 119.034 504 8.001 392.967 8 256.002 7.999 119.193 119.646 7.755 256.455 8z" - - -unlockIcon : Html msg -unlockIcon = - icon "M423.5 0C339.5.3 272 69.5 272 153.5V224H48c-26.5 0-48 21.5-48 48v192c0 26.5 21.5 48 48 48h352c26.5 0 48-21.5 48-48V272c0-26.5-21.5-48-48-48h-48v-71.1c0-39.6 31.7-72.5 71.3-72.9 40-.4 72.7 32.1 72.7 72v80c0 13.3 10.7 24 24 24h32c13.3 0 24-10.7 24-24v-80C576 68 507.5-.3 423.5 0z" - - -lockIcon : Html msg -lockIcon = - icon "M400 224h-24v-72C376 68.2 307.8 0 224 0S72 68.2 72 152v72H48c-26.5 0-48 21.5-48 48v192c0 26.5 21.5 48 48 48h352c26.5 0 48-21.5 48-48V272c0-26.5-21.5-48-48-48zm-104 0H152v-72c0-39.7 32.3-72 72-72s72 32.3 72 72v72z" - - -icon : String -> Html msg -icon path = - div - [ style "display" "inline-flex" - , style "align-self" "center" - , style "top" ".125em" - , style "position" "relative" - ] - [ Svg.svg - [ S.viewBox "0 0 512 512" - , S.width "1em" - , S.height "1em" - ] - [ Svg.path - [ S.fill "currentColor" - , S.d path - ] - [] - ] - ] - - - --- VERSIONS - - -type Version = - Version Int Int Int - - - --- ENCODE CONSTRAINTS - - -encodeConstraint : PBounds -> E.Value -encodeConstraint bounds = - case bounds of - POld (Version x y z) _ oldBounds -> - case oldBounds of - OLocked -> E.string <| v2s x y z ++ " <= v < " ++ v2s x y (z + 1) - OPatch -> E.string <| v2s x y z ++ " <= v < " ++ v2s x y max16 - OMinor -> E.string <| v2s x y z ++ " <= v < " ++ v2s x max16 0 - OMajor -> E.string <| v2s x y z ++ " <= v < " ++ v2s max16 0 0 - OAny -> encodeAny - OCustom c -> Constraint.encode c - - PNew _ newBounds -> - case newBounds of - NAny -> encodeAny - NCustom c -> Constraint.encode c - - -encodeAny : E.Value -encodeAny = - E.string <| v2s 1 0 0 ++ " <= v <= " ++ v2s max16 max16 max16 - - -max16 : Int -max16 = - 65535 - - -v2s : Int -> Int -> Int -> String -v2s major minor patch = - String.fromInt major ++ "." ++ String.fromInt minor ++ "." ++ String.fromInt patch - - - --- DECODE SOLUTION - - -solutionDecoder : D.Decoder (Dict String Version) -solutionDecoder = - D.dict versionDecoder - - -versionDecoder : D.Decoder Version -versionDecoder = - let - toVersion str = - case fromString str of - Just vsn -> D.succeed vsn - Nothing -> D.fail "invalid version number" - in - D.andThen toVersion D.string - - -fromString : String -> Maybe Version -fromString string = - case List.map String.toInt (String.split "." string) of - [Just major, Just minor, Just patch] -> - fromStringHelp major minor patch - - _ -> - Nothing - - -fromStringHelp : Int -> Int -> Int -> Maybe Version -fromStringHelp major minor patch = - if major >= 0 && minor >= 0 && patch >= 0 then - Just (Version major minor patch) - else - Nothing - - - --- TODO delete everything below here - - -styles : String -styles = """ -body { - font-family: sans-serif; - font-size: 16px; - background-color: #cccccc; -} -.search-input { - padding: 0.5em 1em; - border: 1px solid #cccccc; - border-radius: 2px; -} -.search-matches { - position: absolute; - top: 100%; - left: 0; - right: 0; - background-color: white; -} -.search-match { - border-left: 1px solid #cccccc; - border-right: 1px solid #cccccc; - border-bottom: 1px solid #cccccc; -} -.search-match:hover { - background-color: #eeeeee; - cursor: pointer; -} -.search-match-focused { - background-color: #60B5CC !important; - border-color: #60B5CC; - color: white; -} -.button { - padding: 0.5em 1em; - border: 1px solid #60B5CC; - background-color: white; - border-radius: 2px; - color: #60B5CC; -} -.button:hover { - color: white; - background-color: #60B5CC; -} -.button:active { - color: white; - border-color: #5A6378; - background-color: #5A6378; -} -.button-inactive { - padding: 0.5em 1em; - border: 1px solid #cccccc; - background-color: white; - border-radius: 2px; - color: #cccccc; -} -.table-title { - text-transform: uppercase; - color: #cccccc; - font-size: .75em; -} -""" - - -elmJson : String -elmJson = """ -{ - "type": "application", - "source-directories": [ - "src" - ], - "elm-version": "0.19.0", - "dependencies": { - "direct": { - "elm/browser": "1.0.1", - "elm/core": "1.0.2", - "elm/html": "1.0.0", - "elm/http": "2.0.0", - "elm/json": "1.1.2", - "elm/project-metadata-utils": "1.0.0", - "elm/svg": "1.0.1", - "elm-explorations/markdown": "1.0.0" - }, - "indirect": { - "elm/bytes": "1.0.7", - "elm/file": "1.0.1", - "elm/parser": "1.1.0", - "elm/time": "1.0.0", - "elm/url": "1.0.0", - "elm/virtual-dom": "1.0.2" - } - }, - "test-dependencies": { - "direct": {}, - "indirect": {} - } -} -""" diff --git a/reactor/src/Errors.elm b/reactor/src/Errors.elm deleted file mode 100644 index 9c8c63936d..0000000000 --- a/reactor/src/Errors.elm +++ /dev/null @@ -1,207 +0,0 @@ -module Errors exposing (main) - - -import Browser -import Char -import Html exposing (..) -import Html.Attributes exposing (..) -import String -import Json.Decode as D -import Elm.Error as Error - - - --- MAIN - - -main = - Browser.document - { init = \flags -> (D.decodeValue Error.decoder flags, Cmd.none) - , update = \_ exit -> (exit, Cmd.none) - , view = view - , subscriptions = \_ -> Sub.none - } - - - --- VIEW - - -view : Result D.Error Error.Error -> Browser.Document msg -view result = - { title = "Problem!" - , body = - case result of - Err err -> - [ text (D.errorToString err) ] - - Ok error -> - [ viewError error ] - } - - -viewError : Error.Error -> Html msg -viewError error = - div - [ style "width" "100%" - , style "min-height" "100%" - , style "display" "flex" - , style "flex-direction" "column" - , style "align-items" "center" - , style "background-color" "rgb(39, 40, 34)" - , style "color" "rgb(233, 235, 235)" - , style "font-family" "monospace" - ] - [ div - [ style "display" "block" - , style "white-space" "pre-wrap" - , style "background-color" "black" - , style "padding" "2em" - ] - (viewErrorHelp error) - ] - - -viewErrorHelp : Error.Error -> List (Html msg) -viewErrorHelp error = - case error of - Error.GeneralProblem { path, title, message } -> - viewHeader title path :: viewMessage message - - Error.ModuleProblems badModules -> - viewBadModules badModules - - - --- VIEW HEADER - - -viewHeader : String -> Maybe String -> Html msg -viewHeader title maybeFilePath = - let - left = "-- " ++ title ++ " " - right = - case maybeFilePath of - Nothing -> - "" - Just filePath -> - " " ++ filePath - in - span [ style "color" "rgb(51,187,200)" ] [ text (fill left right ++ "\n\n") ] - - -fill : String -> String -> String -fill left right = - left ++ String.repeat (80 - String.length left - String.length right) "-" ++ right - - - --- VIEW BAD MODULES - - -viewBadModules : List Error.BadModule -> List (Html msg) -viewBadModules badModules = - case badModules of - [] -> - [] - - [badModule] -> - [viewBadModule badModule] - - a :: b :: cs -> - viewBadModule a :: viewSeparator a.name b.name :: viewBadModules (b :: cs) - - -viewBadModule : Error.BadModule -> Html msg -viewBadModule { path, problems } = - span [] (List.map (viewProblem path) problems) - - -viewProblem : String -> Error.Problem -> Html msg -viewProblem filePath problem = - span [] (viewHeader problem.title (Just filePath) :: viewMessage problem.message) - - -viewSeparator : String -> String -> Html msg -viewSeparator before after = - span [ style "color" "rgb(211,56,211)" ] - [ text <| - String.padLeft 80 ' ' (before ++ " ↑ ") ++ "\n" ++ - "====o======================================================================o====\n" ++ - " ↓ " ++ after ++ "\n\n\n" - ] - - - --- VIEW MESSAGE - - -viewMessage : List Error.Chunk -> List (Html msg) -viewMessage chunks = - case chunks of - [] -> - [ text "\n\n\n" ] - - chunk :: others -> - let - htmlChunk = - case chunk of - Error.Unstyled string -> - text string - - Error.Styled style string -> - span (styleToAttrs style) [ text string ] - in - htmlChunk :: viewMessage others - - -styleToAttrs : Error.Style -> List (Attribute msg) -styleToAttrs { bold, underline, color } = - addBold bold <| addUnderline underline <| addColor color [] - - -addBold : Bool -> List (Attribute msg) -> List (Attribute msg) -addBold bool attrs = - if bool then - style "font-weight" "bold" :: attrs - else - attrs - - -addUnderline : Bool -> List (Attribute msg) -> List (Attribute msg) -addUnderline bool attrs = - if bool then - style "text-decoration" "underline" :: attrs - else - attrs - - -addColor : Maybe Error.Color -> List (Attribute msg) -> List (Attribute msg) -addColor maybeColor attrs = - case maybeColor of - Nothing -> - attrs - - Just color -> - style "color" (colorToCss color) :: attrs - - -colorToCss : Error.Color -> String -colorToCss color = - case color of - Error.Red -> "rgb(194,54,33)" - Error.RED -> "rgb(252,57,31)" - Error.Magenta -> "rgb(211,56,211)" - Error.MAGENTA -> "rgb(249,53,248)" - Error.Yellow -> "rgb(173,173,39)" - Error.YELLOW -> "rgb(234,236,35)" - Error.Green -> "rgb(37,188,36)" - Error.GREEN -> "rgb(49,231,34)" - Error.Cyan -> "rgb(51,187,200)" - Error.CYAN -> "rgb(20,240,240)" - Error.Blue -> "rgb(73,46,225)" - Error.BLUE -> "rgb(88,51,255)" - Error.White -> "rgb(203,204,205)" - Error.WHITE -> "rgb(233,235,235)" - Error.Black -> "rgb(0,0,0)" - Error.BLACK -> "rgb(129,131,131)" diff --git a/reactor/src/Index.elm b/reactor/src/Index.elm deleted file mode 100644 index 288616e478..0000000000 --- a/reactor/src/Index.elm +++ /dev/null @@ -1,280 +0,0 @@ -module Index exposing (main) - - -import Browser -import Dict -import Html exposing (..) -import Html.Attributes exposing (class, href, src, style, title) -import Json.Decode as D - -import Elm.License as License -import Elm.Package as Package -import Elm.Project as Project -import Elm.Version as Version - -import Index.Icon as Icon -import Index.Navigator as Navigator -import Index.Skeleton as Skeleton - - - --- MAIN - - -main : Program D.Value Model Never -main = - Browser.document - { init = \flags -> (D.decodeValue decoder flags, Cmd.none) - , update = \_ model -> (model, Cmd.none) - , subscriptions = \_ -> Sub.none - , view = view - } - - - --- FLAGS - - -type alias Flags = - { root : String - , pwd : List String - , dirs : List String - , files : List File - , readme : Maybe String - , project : Maybe Project.Project - , exactDeps : Dict.Dict String Version.Version - } - - -type alias File = - { name : String - , runnable : Bool - } - - - --- DECODER - - -decoder : D.Decoder Flags -decoder = - D.map7 Flags - (D.field "root" D.string) - (D.field "pwd" (D.list D.string)) - (D.field "dirs" (D.list D.string)) - (D.field "files" (D.list fileDecoder)) - (D.field "readme" (D.nullable D.string)) - (D.field "outline" (D.nullable Project.decoder)) - (D.field "exactDeps" (D.dict Version.decoder)) - - -fileDecoder : D.Decoder File -fileDecoder = - D.map2 File - (D.field "name" D.string) - (D.field "runnable" D.bool) - - - --- MODEL - - -type alias Model = - Result D.Error Flags - - - --- VIEW - - -view : Model -> Browser.Document msg -view model = - case model of - Err error -> - { title = "???" - , body = - [ text (D.errorToString error) - ] - } - - Ok { root, pwd, dirs, files, readme, project, exactDeps } -> - { title = String.join "/" ("~" :: pwd) - , body = - [ header [ class "header" ] [] - , div [ class "content" ] - [ Navigator.view root pwd - , viewLeftColumn dirs files readme - , viewRightColumn exactDeps project - , div [ style "clear" "both" ] [] - ] - ] - } - - -viewLeftColumn : List String -> List File -> Maybe String -> Html msg -viewLeftColumn dirs files readme = - section [ class "left-column" ] - [ viewFiles dirs files - , viewReadme readme - ] - - -viewRightColumn : ExactDeps -> Maybe Project.Project -> Html msg -viewRightColumn exactDeps maybeProject = - section [ class "right-column" ] <| - case maybeProject of - Nothing -> - [] - - Just project -> - [ viewProjectSummary project - , viewDeps exactDeps project - , viewTestDeps exactDeps project - ] - - --- VIEW README - - -viewReadme : Maybe String -> Html msg -viewReadme readme = - case readme of - Nothing -> - text "" - - Just markdown -> - Skeleton.readmeBox markdown - - - --- VIEW FILES - - -viewFiles : List String -> List File -> Html msg -viewFiles dirs files = - Skeleton.box - { title = "File Navigation" - , items = - List.filterMap viewDir (List.sort dirs) - ++ - List.filterMap viewFile (List.sortBy .name files) - , footer = Nothing - } - - -viewDir : String -> Maybe (List (Html msg)) -viewDir dir = - if String.startsWith "." dir || dir == "elm-stuff" then - Nothing - else - Just [ a [ href dir ] [ Icon.folder, text dir ] ] - - -viewFile : File -> Maybe (List (Html msg)) -viewFile {name} = - if String.startsWith "." name then - Nothing - else - Just [ a [ href name ] [ Icon.lookup name, text name ] ] - - - --- VIEW PAGE SUMMARY - - -viewProjectSummary : Project.Project -> Html msg -viewProjectSummary project = - case project of - Project.Application info -> - Skeleton.box - { title = "Source Directories" - , items = List.map (\dir -> [text dir]) info.dirs - , footer = Nothing - } - -- TODO show estimated bundle size here - - Project.Package info -> - Skeleton.box - { title = "Package Info" - , items = - [ [ text ("Name: " ++ Package.toString info.name) ] - , [ text ("Version: " ++ Version.toString info.version) ] - , [ text ("License: " ++ License.toString info.license) ] - ] - , footer = Nothing - } - - - --- VIEW DEPENDENCIES - - -type alias ExactDeps = - Dict.Dict String Version.Version - - -viewDeps : ExactDeps -> Project.Project -> Html msg -viewDeps exactDeps project = - let - dependencies = - case project of - Project.Application info -> - List.map viewVersion info.depsDirect - - Project.Package info -> - List.map (viewConstraint exactDeps) info.deps - in - Skeleton.box - { title = "Dependencies" - , items = dependencies - , footer = Nothing -- TODO Just ("/_elm/dependencies", "Add more dependencies?") - } - - -viewTestDeps : ExactDeps -> Project.Project -> Html msg -viewTestDeps exactDeps project = - let - dependencies = - case project of - Project.Application info -> - List.map viewVersion info.testDepsDirect - - Project.Package info -> - List.map (viewConstraint exactDeps) info.testDeps - in - Skeleton.box - { title = "Test Dependencies" - , items = dependencies - , footer = Nothing -- TODO Just ("/_elm/test-dependencies", "Add more test dependencies?") - } - - -viewVersion : (Package.Name, Version.Version) -> List (Html msg) -viewVersion (pkg, version) = - [ div [ style "float" "left" ] - [ Icon.package - , a [ href (toPackageUrl pkg version) ] [ text (Package.toString pkg) ] - ] - , div [ style "float" "right" ] [ text (Version.toString version) ] - ] - - -viewConstraint : ExactDeps -> (Package.Name, constraint) -> List (Html msg) -viewConstraint exactDeps (pkg, _) = - case Dict.get (Package.toString pkg) exactDeps of - Just vsn -> - viewVersion (pkg, vsn) - - Nothing -> - [ div [ style "float" "left" ] - [ Icon.package - , text (Package.toString pkg) - ] - , div [ style "float" "right" ] [ text "???" ] - ] - - -toPackageUrl : Package.Name -> Version.Version -> String -toPackageUrl name version = - "https://package.elm-lang.org/packages/" - ++ Package.toString name ++ "/" ++ Version.toString version diff --git a/reactor/src/Index/Icon.elm b/reactor/src/Index/Icon.elm deleted file mode 100644 index 5a40ed790b..0000000000 --- a/reactor/src/Index/Icon.elm +++ /dev/null @@ -1,111 +0,0 @@ -module Index.Icon exposing - ( home - , image - , file - , gift - , folder - , package - , plus - , lookup - ) - -import Dict -import Html exposing (Html) -import Svg exposing (..) -import Svg.Attributes exposing (class, width, height, viewBox, d, fill) - - - --- ICON - - -icon : String -> String -> String -> Html msg -icon color size pathString = - svg - [ class "icon" - , width size - , height size - , viewBox "0 0 1792 1792" - ] - [ path [ fill color, d pathString ] [] - ] - - - --- NECESSARY ICONS - - -home : Html msg -home = - icon "#babdb6" "36px" "M1472 992v480q0 26-19 45t-45 19h-384v-384h-256v384h-384q-26 0-45-19t-19-45v-480q0-1 .5-3t.5-3l575-474 575 474q1 2 1 6zm223-69l-62 74q-8 9-21 11h-3q-13 0-21-7l-692-577-692 577q-12 8-24 7-13-2-21-11l-62-74q-8-10-7-23.5t11-21.5l719-599q32-26 76-26t76 26l244 204v-195q0-14 9-23t23-9h192q14 0 23 9t9 23v408l219 182q10 8 11 21.5t-7 23.5z" - - -image : Html msg -image = - icon "#babdb6" "16px" "M1596 380q28 28 48 76t20 88v1152q0 40-28 68t-68 28h-1344q-40 0-68-28t-28-68v-1600q0-40 28-68t68-28h896q40 0 88 20t76 48zm-444-244v376h376q-10-29-22-41l-313-313q-12-12-41-22zm384 1528v-1024h-416q-40 0-68-28t-28-68v-416h-768v1536h1280zm-128-448v320h-1024v-192l192-192 128 128 384-384zm-832-192q-80 0-136-56t-56-136 56-136 136-56 136 56 56 136-56 136-136 56z" - - -file : Html msg -file = - icon "#babdb6" "16px" "M1596 380q28 28 48 76t20 88v1152q0 40-28 68t-68 28h-1344q-40 0-68-28t-28-68v-1600q0-40 28-68t68-28h896q40 0 88 20t76 48zm-444-244v376h376q-10-29-22-41l-313-313q-12-12-41-22zm384 1528v-1024h-416q-40 0-68-28t-28-68v-416h-768v1536h1280zm-1024-864q0-14 9-23t23-9h704q14 0 23 9t9 23v64q0 14-9 23t-23 9h-704q-14 0-23-9t-9-23v-64zm736 224q14 0 23 9t9 23v64q0 14-9 23t-23 9h-704q-14 0-23-9t-9-23v-64q0-14 9-23t23-9h704zm0 256q14 0 23 9t9 23v64q0 14-9 23t-23 9h-704q-14 0-23-9t-9-23v-64q0-14 9-23t23-9h704z" - - -gift : Html msg -gift = - icon "#babdb6" "16px" "M1056 1356v-716h-320v716q0 25 18 38.5t46 13.5h192q28 0 46-13.5t18-38.5zm-456-844h195l-126-161q-26-31-69-31-40 0-68 28t-28 68 28 68 68 28zm688-96q0-40-28-68t-68-28q-43 0-69 31l-125 161h194q40 0 68-28t28-68zm376 256v320q0 14-9 23t-23 9h-96v416q0 40-28 68t-68 28h-1088q-40 0-68-28t-28-68v-416h-96q-14 0-23-9t-9-23v-320q0-14 9-23t23-9h440q-93 0-158.5-65.5t-65.5-158.5 65.5-158.5 158.5-65.5q107 0 168 77l128 165 128-165q61-77 168-77 93 0 158.5 65.5t65.5 158.5-65.5 158.5-158.5 65.5h440q14 0 23 9t9 23z" - - -folder : Html msg -folder = - icon "#babdb6" "16px" "M1728 608v704q0 92-66 158t-158 66h-1216q-92 0-158-66t-66-158v-960q0-92 66-158t158-66h320q92 0 158 66t66 158v32h672q92 0 158 66t66 158z" - - -package : Html msg -package = - icon "#babdb6" "16px" "M1088 832q0-26-19-45t-45-19h-256q-26 0-45 19t-19 45 19 45 45 19h256q26 0 45-19t19-45zm576-192v960q0 26-19 45t-45 19h-1408q-26 0-45-19t-19-45v-960q0-26 19-45t45-19h1408q26 0 45 19t19 45zm64-448v256q0 26-19 45t-45 19h-1536q-26 0-45-19t-19-45v-256q0-26 19-45t45-19h1536q26 0 45 19t19 45z" - - -plus : Html msg -plus = - icon "#babdb6" "16px" "M1600 736v192q0 40-28 68t-68 28h-416v416q0 40-28 68t-68 28h-192q-40 0-68-28t-28-68v-416h-416q-40 0-68-28t-28-68v-192q0-40 28-68t68-28h416v-416q0-40 28-68t68-28h192q40 0 68 28t28 68v416h416q40 0 68 28t28 68z" - - - --- LOOKUP - - -lookup : String -> Html msg -lookup fileName = - let - extension = - getExtension fileName - in - Maybe.withDefault file (Dict.get extension extensionIcons) - - -extensionIcons : Dict.Dict String (Html msg) -extensionIcons = - Dict.fromList - [ ("jpg" , image) - , ("jpeg", image) - , ("png" , image) - , ("gif" , image) - ] - - -getExtension : String -> String -getExtension str = - getExtensionHelp (String.split "." str) - - -getExtensionHelp : List String -> String -getExtensionHelp segments = - case segments of - [] -> - "" - - [ext] -> - String.toLower ext - - _ :: rest -> - getExtensionHelp rest diff --git a/reactor/src/Index/Navigator.elm b/reactor/src/Index/Navigator.elm deleted file mode 100644 index d28673708b..0000000000 --- a/reactor/src/Index/Navigator.elm +++ /dev/null @@ -1,63 +0,0 @@ -module Index.Navigator exposing (view) - - -import Html exposing (..) -import Html.Attributes exposing (..) -import Index.Icon as Icon - - - --- VIEW - - -view : String -> List String -> Html msg -view root dirs = - div - [ style "font-size" "2em" - , style "padding" "20px 0" - , style "display" "flex" - , style "align-items" "center" - , style "height" "40px" - ] - (makeLinks root dirs "" []) - - -makeLinks : String -> List String -> String -> List (Html msg) -> List (Html msg) -makeLinks root dirs oldPath revAnchors = - case dirs of - dir :: otherDirs -> - let - newPath = - oldPath ++ "/" ++ dir - - anchor = - a [ href newPath ] [ text dir ] - in - makeLinks root otherDirs newPath (anchor :: revAnchors) - - [] -> - let - home = - a [ href "/" - , title root - , style "display" "inherit" - ] - [ Icon.home - ] - in - case revAnchors of - [] -> - [home] - - lastAnchor :: otherRevAnchors -> - home :: slash :: List.foldl addSlash [lastAnchor] otherRevAnchors - - -addSlash : Html msg -> List (Html msg) -> List (Html msg) -addSlash front back = - front :: slash :: back - - -slash : Html msg -slash = - span [ style "padding" "0 8px" ] [ text "/" ] diff --git a/reactor/src/Index/Skeleton.elm b/reactor/src/Index/Skeleton.elm deleted file mode 100644 index 3a0f77444d..0000000000 --- a/reactor/src/Index/Skeleton.elm +++ /dev/null @@ -1,61 +0,0 @@ -module Index.Skeleton exposing - ( box - , readmeBox - ) - -import Html exposing (..) -import Html.Attributes exposing (..) -import Markdown - -import Index.Icon as Icon - - - --- VIEW BOXES - - -type alias BoxArgs msg = - { title : String - , items : List (List (Html msg)) - , footer : Maybe (String, String) - } - - -box : BoxArgs msg -> Html msg -box { title, items, footer } = - let - realItems = - List.map (div [ class "box-item" ]) items - in - boxHelp title realItems footer - - -readmeBox : String -> Html msg -readmeBox markdown = - let - readme = - Markdown.toHtml [ class "box-item" ] markdown - in - boxHelp "README" [readme] Nothing - - -boxHelp : String -> List (Html msg) -> Maybe (String, String) -> Html msg -boxHelp boxTitle items footer = - div [ class "box" ] <| - div [ class "box-header" ] [ text boxTitle ] - :: items - ++ [ boxFooter footer ] - - -boxFooter : Maybe (String, String) -> Html msg -boxFooter maybeFooter = - case maybeFooter of - Nothing -> - text "" - - Just (path, description) -> - a [ href path - , title description - ] - [ div [ class "box-footer" ] [ Icon.plus ] - ] diff --git a/reactor/src/NotFound.elm b/reactor/src/NotFound.elm deleted file mode 100644 index 58dbf1a696..0000000000 --- a/reactor/src/NotFound.elm +++ /dev/null @@ -1,29 +0,0 @@ -module NotFound exposing (main) - - -import Browser -import Html exposing (..) -import Html.Attributes exposing (..) - - - -main : Program () () () -main = - Browser.document - { init = \_ -> ((), Cmd.none) - , update = \_ _ -> ((), Cmd.none) - , subscriptions = \_ -> Sub.none - , view = \_ -> page - } - - -page : Browser.Document () -page = - { title = "Page not found" - , body = - [ div [ class "not-found" ] - [ div [ style "font-size" "12em" ] [ text "404" ] - , div [ style "font-size" "3em" ] [ text "Page not found" ] - ] - ] - } \ No newline at end of file diff --git a/reactor/src/mock.txt b/reactor/src/mock.txt deleted file mode 100644 index 786944769d..0000000000 --- a/reactor/src/mock.txt +++ /dev/null @@ -1,33 +0,0 @@ -# Dependency Explorer - -Mass Updates: | RESET | PATCH | MINOR | MAJOR | - -⣿⣿⣿⣿⣿⣿⣿⣿⣿⣿⣿⣿⣿⣿⣿⣿⣿⣿⣿⣿⣿⣿⣿⣿⣇ ←→ - -DEPENDENCIES - - DIRECT - NoRedInk/elm-json-decode-pipeline 1.0.0 → 3.0.0 (MAJOR) - elm/browser 1.0.0 → 1.0.2 (MINOR) - elm/core 1.0.0 → 1.0.5 (CUSTOM: 1.0.0 <= v < 2.0.0) - elm/html 1.0.0 → 6.0.2 (ANY) - elm/http 1.0.0 → 1.0.0 (LOCKED) - elm/json 1.0.0 → 1.0.0 (LOCKED) - elm/time 1.0.0 → 1.0.0 (LOCKED) - elm/url 1.0.0 → 1.0.0 (LOCKED) - elm-explorations/markdown 1.0.0 → 1.0.0 (LOCKED) - rtfeldman/elm-iso8601-date-strings 1.1.0 → (REMOVE) - ADD - - INDIRECT - elm/parser 1.0.0 → 1.0.0 (LOCKED) - elm/virtual-dom 1.0.0 → 1.0.0 (LOCKED) - -TEST DEPENDENCIES - - DIRECT - elm-explorations/test 1.0.0 → 1.0.0 (LOCKED) - ADD - - INDIRECT - elm/random 1.0.0 → 1.0.0 (LOCKED) diff --git a/review/elm.json b/review/elm.json new file mode 100644 index 0000000000..97477f9a55 --- /dev/null +++ b/review/elm.json @@ -0,0 +1,41 @@ +{ + "type": "application", + "source-directories": [ + "src" + ], + "elm-version": "0.19.1", + "dependencies": { + "direct": { + "elm/core": "1.0.5", + "elm/json": "1.1.3", + "elm/project-metadata-utils": "1.0.2", + "jfmengels/elm-review": "2.15.1", + "jfmengels/elm-review-code-style": "1.2.0", + "jfmengels/elm-review-common": "1.3.3", + "jfmengels/elm-review-debug": "1.0.8", + "jfmengels/elm-review-documentation": "2.0.4", + "jfmengels/elm-review-simplify": "2.1.6", + "jfmengels/elm-review-unused": "1.2.4", + "stil4m/elm-syntax": "7.3.8" + }, + "indirect": { + "elm/bytes": "1.0.8", + "elm/html": "1.0.0", + "elm/parser": "1.1.0", + "elm/random": "1.0.0", + "elm/regex": "1.0.0", + "elm/time": "1.0.0", + "elm/virtual-dom": "1.0.3", + "elm-explorations/test": "2.2.0", + "pzp1997/assoc-list": "1.0.0", + "rtfeldman/elm-hex": "1.0.0", + "stil4m/structured-writer": "1.0.3" + } + }, + "test-dependencies": { + "direct": { + "elm-explorations/test": "2.2.0" + }, + "indirect": {} + } +} diff --git a/review/src/ReviewConfig.elm b/review/src/ReviewConfig.elm new file mode 100644 index 0000000000..12848e065b --- /dev/null +++ b/review/src/ReviewConfig.elm @@ -0,0 +1,61 @@ +module ReviewConfig exposing (config) + +{-| Do not rename the ReviewConfig module or the config function, because +`elm-review` will look for these. + +To add packages that contain rules, add them to this review project using + + `elm install author/packagename` + +when inside the directory containing this file. + +-} + +import Docs.ReviewAtDocs +import NoConfusingPrefixOperator +import NoDebug.Log +import NoDebug.TodoOrToString +import NoExposingEverything +import NoImportingEverything +import NoMissingTypeAnnotation +import NoMissingTypeAnnotationInLetIn +import NoMissingTypeExpose +import NoPrematureLetComputation +import NoSimpleLetBody +import NoUnused.CustomTypeConstructorArgs +import NoUnused.CustomTypeConstructors +import NoUnused.Dependencies +import NoUnused.Exports +import NoUnused.Parameters +import NoUnused.Patterns +import NoUnused.Variables +import Review.Rule as Rule exposing (Rule) +import Simplify + + +config : List Rule +config = + [ Docs.ReviewAtDocs.rule + , NoConfusingPrefixOperator.rule + , NoDebug.Log.rule + , NoDebug.TodoOrToString.rule + |> Rule.ignoreErrorsForDirectories [ "tests/" ] + , NoExposingEverything.rule + , NoImportingEverything.rule [] + , NoMissingTypeAnnotation.rule + , NoMissingTypeAnnotationInLetIn.rule + , NoMissingTypeExpose.rule + , NoSimpleLetBody.rule + , NoPrematureLetComputation.rule + + -- , NoUnused.CustomTypeConstructors.rule [] + -- , NoUnused.CustomTypeConstructorArgs.rule + , NoUnused.Dependencies.rule + + -- , NoUnused.Exports.rule + , NoUnused.Parameters.rule + |> Rule.ignoreErrorsForFiles [ "src/Utils/Crash.elm" ] + , NoUnused.Patterns.rule + , NoUnused.Variables.rule + , Simplify.rule Simplify.defaults + ] diff --git a/scripts/build.sh b/scripts/build.sh new file mode 100755 index 0000000000..a648384398 --- /dev/null +++ b/scripts/build.sh @@ -0,0 +1,36 @@ +#!/bin/sh + +# Ref.: https://github.com/elm/compiler/blob/master/hints/optimize.md + +set -e + +case $1 in + "node") + filepath="lib/guida.node" + elm_entry="src/Node/Main.elm" + ;; + "browser") + filepath="lib/guida.browser" + elm_entry="src/Browser/Main.elm" + ;; + "bin") + filepath="bin/guida" + elm_entry="src/Terminal/Main.elm" + ;; + *) + echo "Usage: $0 node|browser|bin" + exit 1 + ;; +esac + +js="$filepath.js" +min="$filepath.min.js" + +guida make --optimize --output=$js $elm_entry +node scripts/replacements.js $js + +uglifyjs $js --compress "pure_funcs=[F2,F3,F4,F5,F6,F7,F8,F9,A2,A3,A4,A5,A6,A7,A8,A9],pure_getters,keep_fargs=false,unsafe_comps,unsafe" | uglifyjs --mangle --output $min + +echo "Initial size: $(cat $js | wc -c) bytes ($js)" +echo "Minified size:$(cat $min | wc -c) bytes ($min)" +echo "Gzipped size: $(cat $min | gzip -c | wc -c) bytes" \ No newline at end of file diff --git a/scripts/performance-comparison.sh b/scripts/performance-comparison.sh new file mode 100755 index 0000000000..fa927bedc3 --- /dev/null +++ b/scripts/performance-comparison.sh @@ -0,0 +1,30 @@ +# Clean all +rm -rf guida-stuff ~/.guida elm-stuff ~/.elm + +echo "------------------" + +# GUIDA + +## Run initial guida +time ./bin/index.js make src/Terminal/Main.elm + +## Clean local guida-stuff +rm -rf guida-stuff +time ./bin/index.js make src/Terminal/Main.elm + +## No clean (guida) +time ./bin/index.js make src/Terminal/Main.elm + +echo "------------------" + +# ELM + +## Run initial elm +time elm make src/Terminal/Main.elm + +## Clean local elm-stuff +rm -rf elm-stuff +time elm make src/Terminal/Main.elm + +## No clean (elm) +time elm make src/Terminal/Main.elm diff --git a/scripts/replacements.js b/scripts/replacements.js new file mode 100644 index 0000000000..c4b12f7d3b --- /dev/null +++ b/scripts/replacements.js @@ -0,0 +1,100 @@ +#!/usr/bin/env node + +const fs = require('node:fs'); + +const argv = process.argv.slice(2); +const path = argv[0]; + +const data = fs + .readFileSync(path, { encoding: 'utf8', flag: 'r' }) + /* Replaces the Crash.crash function with one that logs to `stderr` and exits with `-1`. */ + .replace(`var $author$project$Utils$Crash$crash = function (str) { +\tcrash: +\twhile (true) { +\t\tvar $temp$str = str; +\t\tstr = $temp$str; +\t\tcontinue crash; +\t} +};`, `var $author$project$Utils$Crash$crash = function (str) { +\tError.stackTraceLimit = Infinity; +\ttry { +\t\tthrow new Error(str); +\t} catch(e) { +\t\tprocess.stderr.write(e.stack); +\t\tprocess.stderr.write("\\\\n"); +\t} +\tprocess.exit(-1); +};`) + + /* Prevents V8 from retaining large "concatenated string" chains, which can cause OOMs. + Tested against `rtfeldman/elm-css` compilation. + + See the related discussion for context: https://discourse.elm-lang.org/t/guida-compiler-was-there-are-3-elm-compilers-written-in-elm/10329/34 + and issue: https://github.com/guida-lang/compiler/issues/107 + */ + .replace(`var _Bytes_read_string = F3(function(len, bytes, offset) +{ +var string = ''; +\tvar end = offset + len; +\tfor (; offset < end;) +\t{ +\t\tvar byte = bytes.getUint8(offset++); +\t\tstring += +\t\t\t(byte < 128) +\t\t\t\t? String.fromCharCode(byte) +\t\t\t\t: +\t\t\t((byte & 0xE0 /* 0b11100000 */) === 0xC0 /* 0b11000000 */) +\t\t\t\t? String.fromCharCode((byte & 0x1F /* 0b00011111 */) << 6 | bytes.getUint8(offset++) & 0x3F /* 0b00111111 */) +\t\t\t\t: +\t\t\t((byte & 0xF0 /* 0b11110000 */) === 0xE0 /* 0b11100000 */) +\t\t\t\t? String.fromCharCode( +\t\t\t\t\t(byte & 0xF /* 0b00001111 */) << 12 +\t\t\t\t\t| (bytes.getUint8(offset++) & 0x3F /* 0b00111111 */) << 6 +\t\t\t\t\t| bytes.getUint8(offset++) & 0x3F /* 0b00111111 */ +\t\t\t\t) +\t\t\t\t: +\t\t\t\t(byte = +\t\t\t\t\t((byte & 0x7 /* 0b00000111 */) << 18 +\t\t\t\t\t\t| (bytes.getUint8(offset++) & 0x3F /* 0b00111111 */) << 12 +\t\t\t\t\t\t| (bytes.getUint8(offset++) & 0x3F /* 0b00111111 */) << 6 +\t\t\t\t\t\t| bytes.getUint8(offset++) & 0x3F /* 0b00111111 */ +\t\t\t\t\t) - 0x10000 +\t\t\t\t, String.fromCharCode(Math.floor(byte / 0x400) + 0xD800, byte % 0x400 + 0xDC00) +\t\t\t\t); +\t} +\treturn _Utils_Tuple2(offset, string); +});`, `var _Bytes_read_string = F3(function(len, bytes, offset) +{ +\tvar string = []; +\tvar end = offset + len; +\tfor (; offset < end;) +\t{ +\t\tvar byte = bytes.getUint8(offset++); +\t\tstring.push( +\t\t\t(byte < 128) +\t\t\t\t? String.fromCharCode(byte) +\t\t\t\t: +\t\t\t((byte & 0xE0 /* 0b11100000 */) === 0xC0 /* 0b11000000 */) +\t\t\t\t? String.fromCharCode((byte & 0x1F /* 0b00011111 */) << 6 | bytes.getUint8(offset++) & 0x3F /* 0b00111111 */) +\t\t\t\t: +\t\t\t((byte & 0xF0 /* 0b11110000 */) === 0xE0 /* 0b11100000 */) +\t\t\t\t? String.fromCharCode( +\t\t\t\t\t(byte & 0xF /* 0b00001111 */) << 12 +\t\t\t\t\t| (bytes.getUint8(offset++) & 0x3F /* 0b00111111 */) << 6 +\t\t\t\t\t| bytes.getUint8(offset++) & 0x3F /* 0b00111111 */ +\t\t\t\t) +\t\t\t\t: +\t\t\t\t(byte = +\t\t\t\t\t((byte & 0x7 /* 0b00000111 */) << 18 +\t\t\t\t\t\t| (bytes.getUint8(offset++) & 0x3F /* 0b00111111 */) << 12 +\t\t\t\t\t\t| (bytes.getUint8(offset++) & 0x3F /* 0b00111111 */) << 6 +\t\t\t\t\t\t| bytes.getUint8(offset++) & 0x3F /* 0b00111111 */ +\t\t\t\t\t) - 0x10000 +\t\t\t\t, String.fromCharCode(Math.floor(byte / 0x400) + 0xD800, byte % 0x400 + 0xDC00) +\t\t\t\t) +\t\t); +\t} +\treturn _Utils_Tuple2(offset, string.join('')); +});`); + +fs.writeFileSync(path, data, { encoding: 'utf8', flag: 'w' }); \ No newline at end of file diff --git a/src/Browser/Format.elm b/src/Browser/Format.elm new file mode 100644 index 0000000000..0688a97160 --- /dev/null +++ b/src/Browser/Format.elm @@ -0,0 +1,20 @@ +module Browser.Format exposing (run) + +import Common.Format +import Compiler.Elm.Package as Pkg +import Compiler.Parse.Module as M +import Compiler.Parse.SyntaxVersion as SV + + + +-- RUN + + +run : String -> Result String String +run src = + Common.Format.format SV.Guida (M.Package Pkg.core) src + |> Result.mapError + (\_ -> + -- FIXME missings errs + "Something went wrong..." + ) diff --git a/src/Browser/Install.elm b/src/Browser/Install.elm new file mode 100644 index 0000000000..2e50e72db6 --- /dev/null +++ b/src/Browser/Install.elm @@ -0,0 +1,345 @@ +module Browser.Install exposing (run) + +import Builder.BackgroundWriter as BW +import Builder.Deps.Registry as Registry +import Builder.Deps.Solver as Solver +import Builder.Elm.Details as Details +import Builder.Elm.Outline as Outline +import Builder.Reporting as Reporting +import Builder.Reporting.Exit as Exit +import Builder.Stuff as Stuff +import Compiler.Elm.Constraint as C +import Compiler.Elm.Package as Pkg +import Compiler.Elm.Version as V +import Data.Map as Dict exposing (Dict) +import System.IO as IO +import Task exposing (Task) +import Utils.Main as Utils exposing (FilePath) +import Utils.Task.Extra as Task + + + +-- RUN + + +run : Pkg.Name -> Task Never () +run pkg = + Reporting.attempt Exit.installToReport + (Stuff.findRoot + |> Task.bind + (\maybeRoot -> + case maybeRoot of + Nothing -> + Task.pure (Err Exit.InstallNoOutline) + + Just root -> + Task.run + (Task.eio Exit.InstallBadRegistry Solver.initEnv + |> Task.bind + (\env -> + Task.eio Exit.InstallBadOutline (Outline.read root) + |> Task.bind + (\oldOutline -> + case oldOutline of + Outline.App outline -> + makeAppPlan env pkg outline + |> Task.bind (\changes -> attemptChanges root env oldOutline V.toChars changes) + + Outline.Pkg outline -> + makePkgPlan env pkg outline + |> Task.bind (\changes -> attemptChanges root env oldOutline C.toChars changes) + ) + ) + ) + ) + ) + + + +-- ATTEMPT CHANGES + + +type Changes vsn + = AlreadyInstalled + | PromoteTest Outline.Outline + | PromoteIndirect Outline.Outline + | Changes Outline.Outline + + +attemptChanges : String -> Solver.Env -> Outline.Outline -> (a -> String) -> Changes a -> Task Exit.Install () +attemptChanges root env oldOutline _ changes = + case changes of + AlreadyInstalled -> + Task.io (IO.putStrLn "It is already installed!") + + PromoteIndirect newOutline -> + attemptChangesHelp root env oldOutline newOutline + + PromoteTest newOutline -> + attemptChangesHelp root env oldOutline newOutline + + Changes newOutline -> + attemptChangesHelp root env oldOutline newOutline + + +attemptChangesHelp : FilePath -> Solver.Env -> Outline.Outline -> Outline.Outline -> Task Exit.Install () +attemptChangesHelp root env oldOutline newOutline = + Task.eio Exit.InstallBadDetails <| + BW.withScope + (\scope -> + Outline.write root newOutline + |> Task.bind (\_ -> Details.verifyInstall scope root env newOutline) + |> Task.bind + (\result -> + case result of + Err exit -> + Outline.write root oldOutline + |> Task.fmap (\_ -> Err exit) + + Ok () -> + IO.putStrLn "Success!" + |> Task.fmap (\_ -> Ok ()) + ) + ) + + + +-- MAKE APP PLAN + + +makeAppPlan : Solver.Env -> Pkg.Name -> Outline.AppOutline -> Task Exit.Install (Changes V.Version) +makeAppPlan (Solver.Env cache _ connection registry) pkg ((Outline.AppOutline elmVersion sourceDirs direct indirect testDirect testIndirect) as outline) = + if Dict.member identity pkg direct then + Task.pure AlreadyInstalled + + else + -- is it already indirect? + case Dict.get identity pkg indirect of + Just vsn -> + Task.pure <| + PromoteIndirect <| + Outline.App <| + Outline.AppOutline elmVersion + sourceDirs + (Dict.insert identity pkg vsn direct) + (Dict.remove identity pkg indirect) + testDirect + testIndirect + + Nothing -> + -- is it already a test dependency? + case Dict.get identity pkg testDirect of + Just vsn -> + Task.pure <| + PromoteTest <| + Outline.App <| + Outline.AppOutline elmVersion + sourceDirs + (Dict.insert identity pkg vsn direct) + indirect + (Dict.remove identity pkg testDirect) + testIndirect + + Nothing -> + -- is it already an indirect test dependency? + case Dict.get identity pkg testIndirect of + Just vsn -> + Task.pure <| + PromoteTest <| + Outline.App <| + Outline.AppOutline elmVersion + sourceDirs + (Dict.insert identity pkg vsn direct) + indirect + testDirect + (Dict.remove identity pkg testIndirect) + + Nothing -> + -- finally try to add it from scratch + case Registry.getVersions_ pkg registry of + Err suggestions -> + case connection of + Solver.Online _ -> + Task.throw (Exit.InstallUnknownPackageOnline pkg suggestions) + + Solver.Offline -> + Task.throw (Exit.InstallUnknownPackageOffline pkg suggestions) + + Ok _ -> + Task.io (Solver.addToApp cache connection registry pkg outline False) + |> Task.bind + (\result -> + case result of + Solver.SolverOk (Solver.AppSolution _ _ app) -> + Task.pure (Changes (Outline.App app)) + + Solver.NoSolution -> + Task.throw (Exit.InstallNoOnlineAppSolution pkg) + + Solver.NoOfflineSolution -> + Task.throw (Exit.InstallNoOfflineAppSolution pkg) + + Solver.SolverErr exit -> + Task.throw (Exit.InstallHadSolverTrouble exit) + ) + + + +-- MAKE PACKAGE PLAN + + +makePkgPlan : Solver.Env -> Pkg.Name -> Outline.PkgOutline -> Task Exit.Install (Changes C.Constraint) +makePkgPlan (Solver.Env cache _ connection registry) pkg (Outline.PkgOutline name summary license version exposed deps test elmVersion) = + if Dict.member identity pkg deps then + Task.pure AlreadyInstalled + + else + -- is already in test dependencies? + case Dict.get identity pkg test of + Just con -> + Task.pure <| + PromoteTest <| + Outline.Pkg <| + Outline.PkgOutline name + summary + license + version + exposed + (Dict.insert identity pkg con deps) + (Dict.remove identity pkg test) + elmVersion + + Nothing -> + -- try to add a new dependency + case Registry.getVersions_ pkg registry of + Err suggestions -> + case connection of + Solver.Online _ -> + Task.throw (Exit.InstallUnknownPackageOnline pkg suggestions) + + Solver.Offline -> + Task.throw (Exit.InstallUnknownPackageOffline pkg suggestions) + + Ok (Registry.KnownVersions _ _) -> + let + old : Dict ( String, String ) Pkg.Name C.Constraint + old = + Dict.union deps test + + cons : Dict ( String, String ) Pkg.Name C.Constraint + cons = + Dict.insert identity pkg C.anything old + in + Task.io (Solver.verify cache connection registry cons) + |> Task.bind + (\result -> + case result of + Solver.SolverOk solution -> + let + (Solver.Details vsn _) = + Utils.find identity pkg solution + + con : C.Constraint + con = + C.untilNextMajor vsn + + new : Dict ( String, String ) Pkg.Name C.Constraint + new = + Dict.insert identity pkg con old + + changes : Dict ( String, String ) Pkg.Name (Change C.Constraint) + changes = + detectChanges old new + + news : Dict ( String, String ) Pkg.Name C.Constraint + news = + Utils.mapMapMaybe identity Pkg.compareName keepNew changes + in + Task.pure <| + Changes <| + Outline.Pkg <| + Outline.PkgOutline name + summary + license + version + exposed + (addNews (Just pkg) news deps) + (addNews Nothing news test) + elmVersion + + Solver.NoSolution -> + Task.throw (Exit.InstallNoOnlinePkgSolution pkg) + + Solver.NoOfflineSolution -> + Task.throw (Exit.InstallNoOfflinePkgSolution pkg) + + Solver.SolverErr exit -> + Task.throw (Exit.InstallHadSolverTrouble exit) + ) + + +addNews : Maybe Pkg.Name -> Dict ( String, String ) Pkg.Name C.Constraint -> Dict ( String, String ) Pkg.Name C.Constraint -> Dict ( String, String ) Pkg.Name C.Constraint +addNews pkg new old = + Dict.merge compare + (Dict.insert identity) + (\k _ n -> Dict.insert identity k n) + (\k c acc -> + if Just k == pkg then + Dict.insert identity k c acc + + else + acc + ) + old + new + Dict.empty + + + +-- CHANGES + + +type Change a + = Insert a + | Change a a + | Remove a + + +detectChanges : Dict ( String, String ) Pkg.Name a -> Dict ( String, String ) Pkg.Name a -> Dict ( String, String ) Pkg.Name (Change a) +detectChanges old new = + Dict.merge compare + (\k v -> Dict.insert identity k (Remove v)) + (\k oldElem newElem acc -> + case keepChange k oldElem newElem of + Just change -> + Dict.insert identity k change acc + + Nothing -> + acc + ) + (\k v -> Dict.insert identity k (Insert v)) + old + new + Dict.empty + + +keepChange : k -> v -> v -> Maybe (Change v) +keepChange _ old new = + if old == new then + Nothing + + else + Just (Change old new) + + +keepNew : Change a -> Maybe a +keepNew change = + case change of + Insert a -> + Just a + + Change _ a -> + Just a + + Remove _ -> + Nothing diff --git a/src/Browser/Main.elm b/src/Browser/Main.elm new file mode 100644 index 0000000000..5d0ba9f339 --- /dev/null +++ b/src/Browser/Main.elm @@ -0,0 +1,118 @@ +module Browser.Main exposing (main) + +import Browser.Format as Format +import Browser.Install as Install +import Browser.Make as Make +import Browser.Uninstall as Uninstall +import Builder.Reporting.Exit as Exit +import Compiler.Elm.Package as Pkg +import Compiler.Json.Encode as E +import Compiler.Parse.Primitives as P +import Json.Decode as Decode +import Json.Encode as Encode +import System.IO as IO +import Task exposing (Task) +import Utils.Impure as Impure +import Utils.Task.Extra as Task + + +main : IO.Program +main = + IO.run app + + +app : Task Never () +app = + getArgs + |> Task.bind + (\args -> + case args of + MakeArgs path debug optimize withSourceMaps -> + Make.run path (Make.Flags debug optimize withSourceMaps) + |> Task.bind + (\result -> + case result of + Ok output -> + exitWithResponse (Encode.object [ ( "output", Encode.string output ) ]) + + Err error -> + exitWithResponse (Encode.object [ ( "error", Encode.string (E.encodeUgly (Exit.toJson (Exit.makeToReport error))) ) ]) + ) + + FormatArgs path -> + case Format.run path of + Ok output -> + exitWithResponse (Encode.object [ ( "output", Encode.string output ) ]) + + Err error -> + exitWithResponse (Encode.object [ ( "error", Encode.string error ) ]) + + InstallArgs pkgString -> + case P.fromByteString Pkg.parser Tuple.pair pkgString of + Ok pkg -> + Install.run pkg + |> Task.bind (\_ -> exitWithResponse Encode.null) + + Err _ -> + exitWithResponse (Encode.object [ ( "error", Encode.string "Invalid package..." ) ]) + + UninstallArgs pkgString -> + case P.fromByteString Pkg.parser Tuple.pair pkgString of + Ok pkg -> + Uninstall.run pkg + |> Task.bind (\_ -> exitWithResponse Encode.null) + + Err _ -> + exitWithResponse (Encode.object [ ( "error", Encode.string "Invalid package..." ) ]) + ) + + +getArgs : Task Never Args +getArgs = + Impure.task "getArgs" [] Impure.EmptyBody (Impure.DecoderResolver argsDecoder) + + +exitWithResponse : Encode.Value -> Task Never a +exitWithResponse value = + Impure.task "exitWithResponse" [] (Impure.JsonBody value) Impure.Crash + + + +-- ARGS + + +type Args + = MakeArgs String Bool Bool Bool + | FormatArgs String + | InstallArgs String + | UninstallArgs String + + +argsDecoder : Decode.Decoder Args +argsDecoder = + Decode.field "command" Decode.string + |> Decode.andThen + (\command -> + case command of + "make" -> + Decode.map4 MakeArgs + (Decode.field "path" Decode.string) + (Decode.field "debug" Decode.bool) + (Decode.field "optimize" Decode.bool) + (Decode.field "sourcemaps" Decode.bool) + + "format" -> + Decode.map FormatArgs + (Decode.field "content" Decode.string) + + "install" -> + Decode.map InstallArgs + (Decode.field "pkg" Decode.string) + + "uninstall" -> + Decode.map UninstallArgs + (Decode.field "pkg" Decode.string) + + _ -> + Decode.fail ("Unknown command: " ++ command) + ) diff --git a/src/Browser/Make.elm b/src/Browser/Make.elm new file mode 100644 index 0000000000..c3cd3b7822 --- /dev/null +++ b/src/Browser/Make.elm @@ -0,0 +1,269 @@ +module Browser.Make exposing + ( Flags(..) + , Output(..) + , ReportType(..) + , docsFile + , output + , parseDocsFile + , parseOutput + , parseReportType + , reportType + , run + ) + +import Builder.BackgroundWriter as BW +import Builder.Build as Build +import Builder.Elm.Details as Details +import Builder.Generate as Generate +import Builder.Reporting as Reporting +import Builder.Reporting.Exit as Exit +import Builder.Stuff as Stuff +import Compiler.AST.Optimized as Opt +import Compiler.Data.NonEmptyList as NE +import Compiler.Elm.ModuleName as ModuleName +import Compiler.Generate.Html as Html +import Maybe.Extra as Maybe +import Task exposing (Task) +import Terminal.Terminal.Internal exposing (Parser(..)) +import Utils.Crash exposing (crash) +import Utils.Main as Utils exposing (FilePath) +import Utils.Task.Extra as Task + + + +-- FLAGS + + +type Flags + = Flags Bool Bool Bool + + +type Output + = JS String + | Html String + | DevNull + + +type ReportType + = Json + + + +-- RUN + + +run : String -> Flags -> Task Never (Result Exit.Make String) +run path flags = + Stuff.findRoot + |> Task.bind + (\maybeRoot -> + case maybeRoot of + Just root -> + runHelp root path flags + + Nothing -> + Task.pure (Err Exit.MakeNoOutline) + ) + + +runHelp : String -> String -> Flags -> Task Never (Result Exit.Make String) +runHelp root path (Flags debug optimize withSourceMaps) = + BW.withScope + (\scope -> + Stuff.withRootLock root <| + Task.run <| + (getMode debug optimize + |> Task.bind + (\desiredMode -> + let + style : Reporting.Style + style = + Reporting.json + in + Task.eio Exit.MakeBadDetails (Details.load style scope root) + |> Task.bind + (\details -> + buildPaths style root details (NE.Nonempty path []) + |> Task.bind + (\artifacts -> + case getMains artifacts of + [] -> + -- Task.pure () + crash "No main!" + + [ name ] -> + toBuilder withSourceMaps Html.leadingLines root details desiredMode artifacts + |> Task.bind (Task.pure << Html.sandwich name) + + _ -> + crash "TODO" + ) + ) + ) + ) + ) + + + +-- GET INFORMATION + + +getMode : Bool -> Bool -> Task Exit.Make DesiredMode +getMode debug optimize = + case ( debug, optimize ) of + ( True, True ) -> + Task.throw Exit.MakeCannotOptimizeAndDebug + + ( True, False ) -> + Task.pure Debug + + ( False, False ) -> + Task.pure Dev + + ( False, True ) -> + Task.pure Prod + + + +-- BUILD PROJECTS + + +buildPaths : Reporting.Style -> FilePath -> Details.Details -> NE.Nonempty FilePath -> Task Exit.Make Build.Artifacts +buildPaths style root details paths = + Task.eio Exit.MakeCannotBuild <| + Build.fromPaths style root details paths + + + +-- GET MAINS + + +getMains : Build.Artifacts -> List ModuleName.Raw +getMains (Build.Artifacts _ _ roots modules) = + List.filterMap (getMain modules) (NE.toList roots) + + +getMain : List Build.Module -> Build.Root -> Maybe ModuleName.Raw +getMain modules root = + case root of + Build.Inside name -> + if List.any (isMain name) modules then + Just name + + else + Nothing + + Build.Outside name _ (Opt.LocalGraph maybeMain _ _) -> + maybeMain + |> Maybe.map (\_ -> name) + + +isMain : ModuleName.Raw -> Build.Module -> Bool +isMain targetName modul = + case modul of + Build.Fresh name _ (Opt.LocalGraph maybeMain _ _) -> + Maybe.isJust maybeMain && name == targetName + + Build.Cached name mainIsDefined _ -> + mainIsDefined && name == targetName + + + +-- TO BUILDER + + +type DesiredMode + = Debug + | Dev + | Prod + + +toBuilder : Bool -> Int -> FilePath -> Details.Details -> DesiredMode -> Build.Artifacts -> Task Exit.Make String +toBuilder withSourceMaps leadingLines root details desiredMode artifacts = + Task.mapError Exit.MakeBadGenerate <| + case desiredMode of + Debug -> + Generate.debug withSourceMaps leadingLines root details artifacts + + Dev -> + Generate.dev withSourceMaps leadingLines root details artifacts + + Prod -> + Generate.prod withSourceMaps leadingLines root details artifacts + + + +-- PARSERS + + +reportType : Parser +reportType = + Parser + { singular = "report type" + , plural = "report types" + , suggest = \_ -> Task.pure [ "json" ] + , examples = \_ -> Task.pure [ "json" ] + } + + +parseReportType : String -> Maybe ReportType +parseReportType string = + if string == "json" then + Just Json + + else + Nothing + + +output : Parser +output = + Parser + { singular = "output file" + , plural = "output files" + , suggest = \_ -> Task.pure [] + , examples = \_ -> Task.pure [ "elm.js", "index.html", "/dev/null" ] + } + + +parseOutput : String -> Maybe Output +parseOutput name = + if isDevNull name then + Just DevNull + + else if hasExt ".html" name then + Just (Html name) + + else if hasExt ".js" name then + Just (JS name) + + else + Nothing + + +docsFile : Parser +docsFile = + Parser + { singular = "json file" + , plural = "json files" + , suggest = \_ -> Task.pure [] + , examples = \_ -> Task.pure [ "docs.json", "documentation.json" ] + } + + +parseDocsFile : String -> Maybe String +parseDocsFile name = + if hasExt ".json" name then + Just name + + else + Nothing + + +hasExt : String -> String -> Bool +hasExt ext path = + Utils.fpTakeExtension path == ext && String.length path > String.length ext + + +isDevNull : String -> Bool +isDevNull name = + name == "/dev/null" || name == "NUL" || name == "<|null" diff --git a/src/Browser/Uninstall.elm b/src/Browser/Uninstall.elm new file mode 100644 index 0000000000..907943a7db --- /dev/null +++ b/src/Browser/Uninstall.elm @@ -0,0 +1,151 @@ +module Browser.Uninstall exposing (run) + +import Builder.BackgroundWriter as BW +import Builder.Deps.Solver as Solver +import Builder.Elm.Details as Details +import Builder.Elm.Outline as Outline +import Builder.Reporting as Reporting +import Builder.Reporting.Exit as Exit +import Builder.Stuff as Stuff +import Compiler.Elm.Constraint as C +import Compiler.Elm.Package as Pkg +import Compiler.Elm.Version as V +import Data.Map as Dict exposing (Dict) +import System.IO as IO +import Task exposing (Task) +import Utils.Main exposing (FilePath) +import Utils.Task.Extra as Task + + + +-- RUN + + +run : Pkg.Name -> Task Never () +run pkg = + Reporting.attempt Exit.uninstallToReport + (Stuff.findRoot + |> Task.bind + (\maybeRoot -> + case maybeRoot of + Nothing -> + Task.pure (Err Exit.UninstallNoOutline) + + Just root -> + Task.run + (Task.eio Exit.UninstallBadRegistry Solver.initEnv + |> Task.bind + (\env -> + Task.eio Exit.UninstallBadOutline (Outline.read root) + |> Task.bind + (\oldOutline -> + case oldOutline of + Outline.App outline -> + makeAppPlan env pkg outline + |> Task.bind (\changes -> attemptChanges root env oldOutline changes) + + Outline.Pkg outline -> + makePkgPlan pkg outline + |> Task.bind (\changes -> attemptChanges root env oldOutline changes) + ) + ) + ) + ) + ) + + + +-- ATTEMPT CHANGES + + +type Changes vsn + = AlreadyNotPresent + | Changes Outline.Outline + + +attemptChanges : String -> Solver.Env -> Outline.Outline -> Changes a -> Task Exit.Uninstall () +attemptChanges root env oldOutline changes = + case changes of + AlreadyNotPresent -> + Task.io (IO.putStrLn "It is not currently installed!") + + Changes newOutline -> + attemptChangesHelp root env oldOutline newOutline + + +attemptChangesHelp : FilePath -> Solver.Env -> Outline.Outline -> Outline.Outline -> Task Exit.Uninstall () +attemptChangesHelp root env oldOutline newOutline = + Task.eio Exit.UninstallBadDetails <| + BW.withScope + (\scope -> + Outline.write root newOutline + |> Task.bind (\_ -> Details.verifyInstall scope root env newOutline) + |> Task.bind + (\result -> + case result of + Err exit -> + Outline.write root oldOutline + |> Task.fmap (\_ -> Err exit) + + Ok () -> + IO.putStrLn "Success!" + |> Task.fmap (\_ -> Ok ()) + ) + ) + + + +-- MAKE APP PLAN + + +makeAppPlan : Solver.Env -> Pkg.Name -> Outline.AppOutline -> Task Exit.Uninstall (Changes V.Version) +makeAppPlan (Solver.Env cache _ connection registry) pkg ((Outline.AppOutline _ _ direct _ testDirect _) as outline) = + case Dict.get identity pkg (Dict.union direct testDirect) of + Just _ -> + Task.io (Solver.removeFromApp cache connection registry pkg outline) + |> Task.bind + (\result -> + case result of + Solver.SolverOk (Solver.AppSolution _ _ app) -> + Task.pure (Changes (Outline.App app)) + + Solver.NoSolution -> + Task.throw (Exit.UninstallNoOnlineAppSolution pkg) + + Solver.NoOfflineSolution -> + Task.throw (Exit.UninstallNoOfflineAppSolution pkg) + + Solver.SolverErr exit -> + Task.throw (Exit.UninstallHadSolverTrouble exit) + ) + + Nothing -> + Task.pure AlreadyNotPresent + + + +-- MAKE PACKAGE PLAN + + +makePkgPlan : Pkg.Name -> Outline.PkgOutline -> Task Exit.Uninstall (Changes C.Constraint) +makePkgPlan pkg (Outline.PkgOutline name summary license version exposed deps test elmVersion) = + let + old : Dict ( String, String ) Pkg.Name C.Constraint + old = + Dict.union deps test + in + if Dict.member identity pkg old then + Task.pure <| + Changes <| + Outline.Pkg <| + Outline.PkgOutline name + summary + license + version + exposed + (Dict.remove identity pkg deps) + (Dict.remove identity pkg test) + elmVersion + + else + Task.pure AlreadyNotPresent diff --git a/src/Builder/BackgroundWriter.elm b/src/Builder/BackgroundWriter.elm new file mode 100644 index 0000000000..cd7a67519b --- /dev/null +++ b/src/Builder/BackgroundWriter.elm @@ -0,0 +1,63 @@ +module Builder.BackgroundWriter exposing + ( Scope + , withScope + , writeBinary + ) + +import Builder.File as File +import Task exposing (Task) +import Utils.Bytes.Decode as BD +import Utils.Bytes.Encode as BE +import Utils.Main as Utils +import Utils.Task.Extra as Task + + + +-- BACKGROUND WRITER + + +type Scope + = Scope (Utils.MVar (List (Utils.MVar ()))) + + +withScope : (Scope -> Task Never a) -> Task Never a +withScope callback = + Utils.newMVar (BE.list (\_ -> BE.unit ())) [] + |> Task.bind + (\workList -> + callback (Scope workList) + |> Task.bind + (\result -> + Utils.takeMVar (BD.list Utils.mVarDecoder) workList + |> Task.bind + (\mvars -> + Utils.listTraverse_ (Utils.takeMVar (BD.succeed ())) mvars + |> Task.fmap (\_ -> result) + ) + ) + ) + + +writeBinary : (a -> BE.Encoder) -> Scope -> String -> a -> Task Never () +writeBinary toEncoder (Scope workList) path value = + Utils.newEmptyMVar + |> Task.bind + (\mvar -> + Utils.forkIO + (File.writeBinary toEncoder path value + |> Task.bind (\_ -> Utils.putMVar BE.unit mvar ()) + ) + |> Task.bind + (\_ -> + Utils.takeMVar (BD.list Utils.mVarDecoder) workList + |> Task.bind + (\oldWork -> + let + newWork : List (Utils.MVar ()) + newWork = + mvar :: oldWork + in + Utils.putMVar (BE.list Utils.mVarEncoder) workList newWork + ) + ) + ) diff --git a/src/Builder/Build.elm b/src/Builder/Build.elm new file mode 100644 index 0000000000..9b7988d412 --- /dev/null +++ b/src/Builder/Build.elm @@ -0,0 +1,2395 @@ +module Builder.Build exposing + ( Artifacts(..) + , BResult + , CachedInterface(..) + , Dependencies + , DocsGoal(..) + , Module(..) + , ReplArtifacts(..) + , Root(..) + , cachedInterfaceDecoder + , fromExposed + , fromPaths + , fromRepl + , getRootNames + , ignoreDocs + , keepDocs + , writeDocs + ) + +import Basics.Extra exposing (flip) +import Builder.Elm.Details as Details +import Builder.Elm.Outline as Outline +import Builder.File as File +import Builder.Reporting as Reporting +import Builder.Reporting.Exit as Exit +import Builder.Stuff as Stuff +import Compiler.AST.Canonical as Can +import Compiler.AST.Optimized as Opt +import Compiler.AST.Source as Src +import Compiler.Compile as Compile +import Compiler.Data.Map.Utils as Map +import Compiler.Data.Name as Name +import Compiler.Data.NonEmptyList as NE +import Compiler.Data.OneOrMore as OneOrMore +import Compiler.Elm.Docs as Docs +import Compiler.Elm.Interface as I +import Compiler.Elm.ModuleName as ModuleName +import Compiler.Elm.Package as Pkg +import Compiler.Json.Encode as E +import Compiler.Parse.Module as Parse +import Compiler.Parse.SyntaxVersion as SV +import Compiler.Reporting.Annotation as A +import Compiler.Reporting.Error as Error +import Compiler.Reporting.Error.Docs as EDocs +import Compiler.Reporting.Error.Import as Import +import Compiler.Reporting.Error.Syntax as Syntax +import Compiler.Reporting.Render.Type.Localizer as L +import Data.Graph as Graph +import Data.Map as Dict exposing (Dict) +import Data.Set as EverySet +import System.TypeCheck.IO as TypeCheck +import Task exposing (Task) +import Utils.Bytes.Decode as BD +import Utils.Bytes.Encode as BE +import Utils.Crash exposing (crash) +import Utils.Main as Utils exposing (FilePath, MVar(..)) +import Utils.Task.Extra as Task + + + +-- ENVIRONMENT + + +type Env + = Env Reporting.BKey String Parse.ProjectType (List AbsoluteSrcDir) Details.BuildID (Dict String ModuleName.Raw Details.Local) (Dict String ModuleName.Raw Details.Foreign) + + +makeEnv : Reporting.BKey -> FilePath -> Details.Details -> Task Never Env +makeEnv key root (Details.Details _ validOutline buildID locals foreigns _) = + case validOutline of + Details.ValidApp givenSrcDirs -> + Utils.listTraverse (toAbsoluteSrcDir root) (NE.toList givenSrcDirs) + |> Task.fmap (\srcDirs -> Env key root Parse.Application srcDirs buildID locals foreigns) + + Details.ValidPkg pkg _ _ -> + toAbsoluteSrcDir root (Outline.RelativeSrcDir "src") + |> Task.fmap (\srcDir -> Env key root (Parse.Package pkg) [ srcDir ] buildID locals foreigns) + + + +-- SOURCE DIRECTORY + + +type AbsoluteSrcDir + = AbsoluteSrcDir FilePath + + +toAbsoluteSrcDir : FilePath -> Outline.SrcDir -> Task Never AbsoluteSrcDir +toAbsoluteSrcDir root srcDir = + Task.fmap AbsoluteSrcDir + (Utils.dirCanonicalizePath + (case srcDir of + Outline.AbsoluteSrcDir dir -> + dir + + Outline.RelativeSrcDir dir -> + Utils.fpCombine root dir + ) + ) + + +addRelative : AbsoluteSrcDir -> FilePath -> FilePath +addRelative (AbsoluteSrcDir srcDir) path = + Utils.fpCombine srcDir path + + + +-- FORK + + +{-| PERF try using IORef semephore on file crawl phase? +described in Chapter 13 of Parallel and Concurrent Programming in Haskell by Simon Marlow + +-} +fork : (a -> BE.Encoder) -> Task Never a -> Task Never (MVar a) +fork encoder work = + Utils.newEmptyMVar + |> Task.bind + (\mvar -> + Utils.forkIO (Task.bind (Utils.putMVar encoder mvar) work) + |> Task.fmap (\_ -> mvar) + ) + + +forkWithKey : (k -> comparable) -> (k -> k -> Order) -> (b -> BE.Encoder) -> (k -> a -> Task Never b) -> Dict comparable k a -> Task Never (Dict comparable k (MVar b)) +forkWithKey toComparable keyComparison encoder func dict = + Utils.mapTraverseWithKey toComparable keyComparison (\k v -> fork encoder (func k v)) dict + + + +-- FROM EXPOSED + + +fromExposed : BD.Decoder docs -> (docs -> BE.Encoder) -> Reporting.Style -> FilePath -> Details.Details -> DocsGoal docs -> NE.Nonempty ModuleName.Raw -> Task Never (Result Exit.BuildProblem docs) +fromExposed docsDecoder docsEncoder style root details docsGoal ((NE.Nonempty e es) as exposed) = + Reporting.trackBuild docsDecoder docsEncoder style <| + \key -> + makeEnv key root details + |> Task.bind + (\env -> + Details.loadInterfaces root details + |> Task.bind + (\dmvar -> + -- crawl + Utils.newEmptyMVar + |> Task.bind + (\mvar -> + let + docsNeed : DocsNeed + docsNeed = + toDocsNeed docsGoal + in + Map.fromKeysA identity (fork statusEncoder << crawlModule env mvar docsNeed) (e :: es) + |> Task.bind + (\roots -> + Utils.putMVar statusDictEncoder mvar roots + |> Task.bind + (\_ -> + Utils.dictMapM_ compare (Utils.readMVar statusDecoder) roots + |> Task.bind + (\_ -> + Task.bind (Utils.mapTraverse identity compare (Utils.readMVar statusDecoder)) (Utils.readMVar statusDictDecoder mvar) + |> Task.bind + (\statuses -> + -- compile + checkMidpoint dmvar statuses + |> Task.bind + (\midpoint -> + case midpoint of + Err problem -> + Task.pure (Err (Exit.BuildProjectProblem problem)) + + Ok foreigns -> + Utils.newEmptyMVar + |> Task.bind + (\rmvar -> + forkWithKey identity compare bResultEncoder (checkModule env foreigns rmvar) statuses + |> Task.bind + (\resultMVars -> + Utils.putMVar dictRawMVarBResultEncoder rmvar resultMVars + |> Task.bind + (\_ -> + Utils.mapTraverse identity compare (Utils.readMVar bResultDecoder) resultMVars + |> Task.bind + (\results -> + writeDetails root details results + |> Task.bind + (\_ -> + finalizeExposed root docsGoal exposed results + ) + ) + ) + ) + ) + ) + ) + ) + ) + ) + ) + ) + ) + + + +-- FROM PATHS + + +type Artifacts + = Artifacts Pkg.Name Dependencies (NE.Nonempty Root) (List Module) + + +type Module + = Fresh ModuleName.Raw I.Interface Opt.LocalGraph + | Cached ModuleName.Raw Bool (MVar CachedInterface) + + +type alias Dependencies = + Dict (List String) TypeCheck.Canonical I.DependencyInterface + + +fromPaths : Reporting.Style -> FilePath -> Details.Details -> NE.Nonempty FilePath -> Task Never (Result Exit.BuildProblem Artifacts) +fromPaths style root details paths = + Reporting.trackBuild artifactsDecoder artifactsEncoder style <| + \key -> + makeEnv key root details + |> Task.bind + (\env -> + findRoots env paths + |> Task.bind + (\elroots -> + case elroots of + Err problem -> + Task.pure (Err (Exit.BuildProjectProblem problem)) + + Ok lroots -> + -- crawl + Details.loadInterfaces root details + |> Task.bind + (\dmvar -> + Utils.newMVar statusDictEncoder Dict.empty + |> Task.bind + (\smvar -> + Utils.nonEmptyListTraverse (fork rootStatusEncoder << crawlRoot env smvar) lroots + |> Task.bind + (\srootMVars -> + Utils.nonEmptyListTraverse (Utils.readMVar rootStatusDecoder) srootMVars + |> Task.bind + (\sroots -> + Task.bind (Utils.mapTraverse identity compare (Utils.readMVar statusDecoder)) (Utils.readMVar statusDictDecoder smvar) + |> Task.bind + (\statuses -> + checkMidpointAndRoots dmvar statuses sroots + |> Task.bind + (\midpoint -> + case midpoint of + Err problem -> + Task.pure (Err (Exit.BuildProjectProblem problem)) + + Ok foreigns -> + -- compile + Utils.newEmptyMVar + |> Task.bind + (\rmvar -> + forkWithKey identity compare bResultEncoder (checkModule env foreigns rmvar) statuses + |> Task.bind + (\resultsMVars -> + Utils.putMVar resultDictEncoder rmvar resultsMVars + |> Task.bind + (\_ -> + Utils.nonEmptyListTraverse (fork rootResultEncoder << checkRoot env resultsMVars) sroots + |> Task.bind + (\rrootMVars -> + Utils.mapTraverse identity compare (Utils.readMVar bResultDecoder) resultsMVars + |> Task.bind + (\results -> + writeDetails root details results + |> Task.bind + (\_ -> + Task.fmap (toArtifacts env foreigns results) (Utils.nonEmptyListTraverse (Utils.readMVar rootResultDecoder) rrootMVars) + ) + ) + ) + ) + ) + ) + ) + ) + ) + ) + ) + ) + ) + ) + + + +-- GET ROOT NAMES + + +getRootNames : Artifacts -> NE.Nonempty ModuleName.Raw +getRootNames (Artifacts _ _ roots _) = + NE.map getRootName roots + + +getRootName : Root -> ModuleName.Raw +getRootName root = + case root of + Inside name -> + name + + Outside name _ _ -> + name + + + +-- CRAWL + + +type alias StatusDict = + Dict String ModuleName.Raw (MVar Status) + + +type Status + = SCached Details.Local + | SChanged Details.Local String Src.Module DocsNeed + | SBadImport Import.Problem + | SBadSyntax FilePath File.Time String Syntax.Error + | SForeign Pkg.Name + | SKernel + + +crawlDeps : Env -> MVar StatusDict -> List ModuleName.Raw -> a -> Task Never a +crawlDeps env mvar deps blockedValue = + let + crawlNew : ModuleName.Raw -> () -> Task Never (MVar Status) + crawlNew name () = + fork statusEncoder (crawlModule env mvar (DocsNeed False) name) + in + Utils.takeMVar statusDictDecoder mvar + |> Task.bind + (\statusDict -> + let + depsDict : Dict String ModuleName.Raw () + depsDict = + Map.fromKeys (\_ -> ()) deps + + newsDict : Dict String ModuleName.Raw () + newsDict = + Dict.diff depsDict statusDict + in + Utils.mapTraverseWithKey identity compare crawlNew newsDict + |> Task.bind + (\statuses -> + Utils.putMVar statusDictEncoder mvar (Dict.union statuses statusDict) + |> Task.bind + (\_ -> + Utils.dictMapM_ compare (Utils.readMVar statusDecoder) statuses + |> Task.fmap (\_ -> blockedValue) + ) + ) + ) + + +crawlModule : Env -> MVar StatusDict -> DocsNeed -> ModuleName.Raw -> Task Never Status +crawlModule ((Env _ root projectType srcDirs buildID locals foreigns) as env) mvar ((DocsNeed needsDocs) as docsNeed) name = + let + guidaFileName : String + guidaFileName = + ModuleName.toFilePath name ++ ".guida" + + elmFileName : String + elmFileName = + ModuleName.toFilePath name ++ ".elm" + in + Utils.filterM File.exists (List.map (flip addRelative guidaFileName) srcDirs) + |> Task.bind + (\guidaPaths -> + case guidaPaths of + [ path ] -> + Task.pure [ path ] + + _ -> + Utils.filterM File.exists (List.map (flip addRelative elmFileName) srcDirs) + |> Task.fmap (\elmPaths -> guidaPaths ++ elmPaths) + ) + |> Task.bind + (\paths -> + case paths of + [ path ] -> + case Dict.get identity name foreigns of + Just (Details.Foreign dep deps) -> + Task.pure <| SBadImport <| Import.Ambiguous path [] dep deps + + Nothing -> + File.getTime path + |> Task.bind + (\newTime -> + case Dict.get identity name locals of + Nothing -> + crawlFile env mvar docsNeed name path newTime buildID + + Just ((Details.Local oldPath oldTime deps _ lastChange _) as local) -> + if path /= oldPath || oldTime /= newTime || needsDocs then + crawlFile env mvar docsNeed name path newTime lastChange + + else + crawlDeps env mvar deps (SCached local) + ) + + p1 :: p2 :: ps -> + Task.pure <| SBadImport <| Import.AmbiguousLocal (Utils.fpMakeRelative root p1) (Utils.fpMakeRelative root p2) (List.map (Utils.fpMakeRelative root) ps) + + [] -> + case Dict.get identity name foreigns of + Just (Details.Foreign dep deps) -> + case deps of + [] -> + Task.pure <| SForeign dep + + d :: ds -> + Task.pure <| SBadImport <| Import.AmbiguousForeign dep d ds + + Nothing -> + if Name.isKernel name && Parse.isKernel projectType then + File.exists ("src/" ++ ModuleName.toFilePath name ++ ".js") + |> Task.fmap + (\exists -> + if exists then + SKernel + + else + SBadImport Import.NotFound + ) + + else + Task.pure <| SBadImport Import.NotFound + ) + + +crawlFile : Env -> MVar StatusDict -> DocsNeed -> ModuleName.Raw -> FilePath -> File.Time -> Details.BuildID -> Task Never Status +crawlFile ((Env _ root projectType _ buildID _ _) as env) mvar docsNeed expectedName path time lastChange = + File.readUtf8 (Utils.fpCombine root path) + |> Task.bind + (\source -> + case Parse.fromByteString (SV.fileSyntaxVersion path) projectType source of + Err err -> + Task.pure <| SBadSyntax path time source err + + Ok ((Src.Module _ maybeActualName _ _ imports values _ _ _ _) as modul) -> + case maybeActualName of + Nothing -> + Task.pure <| SBadSyntax path time source (Syntax.ModuleNameUnspecified expectedName) + + Just ((A.At _ actualName) as name) -> + if expectedName == actualName then + let + deps : List Name.Name + deps = + List.map Src.getImportName imports + + local : Details.Local + local = + Details.Local path time deps (List.any isMain values) lastChange buildID + in + crawlDeps env mvar deps (SChanged local source modul docsNeed) + + else + Task.pure <| SBadSyntax path time source (Syntax.ModuleNameMismatch expectedName name) + ) + + +isMain : A.Located Src.Value -> Bool +isMain (A.At _ (Src.Value _ ( _, A.At _ name ) _ _ _)) = + name == Name.main_ + + + +-- CHECK MODULE + + +type alias ResultDict = + Dict String ModuleName.Raw (MVar BResult) + + +type BResult + = RNew Details.Local I.Interface Opt.LocalGraph (Maybe Docs.Module) + | RSame Details.Local I.Interface Opt.LocalGraph (Maybe Docs.Module) + | RCached Bool Details.BuildID (MVar CachedInterface) + | RNotFound Import.Problem + | RProblem Error.Module + | RBlocked + | RForeign I.Interface + | RKernel + + +type CachedInterface + = Unneeded + | Loaded I.Interface + | Corrupted + + +checkModule : Env -> Dependencies -> MVar ResultDict -> ModuleName.Raw -> Status -> Task Never BResult +checkModule ((Env _ root projectType _ _ _ _) as env) foreigns resultsMVar name status = + case status of + SCached ((Details.Local path time deps hasMain lastChange lastCompile) as local) -> + Utils.readMVar resultDictDecoder resultsMVar + |> Task.bind + (\results -> + checkDeps root results deps lastCompile + |> Task.bind + (\depsStatus -> + case depsStatus of + DepsChange ifaces -> + File.readUtf8 path + |> Task.bind + (\source -> + case Parse.fromByteString (SV.fileSyntaxVersion path) projectType source of + Ok modul -> + compile env (DocsNeed False) local source ifaces modul + + Err err -> + Task.pure <| + RProblem <| + Error.Module name path time source (Error.BadSyntax err) + ) + + DepsSame _ _ -> + Utils.newMVar cachedInterfaceEncoder Unneeded + |> Task.fmap + (\mvar -> + RCached hasMain lastChange mvar + ) + + DepsBlock -> + Task.pure RBlocked + + DepsNotFound problems -> + File.readUtf8 path + |> Task.bind + (\source -> + Task.pure <| + RProblem <| + Error.Module name path time source <| + case Parse.fromByteString (SV.fileSyntaxVersion path) projectType source of + Ok (Src.Module _ _ _ _ imports _ _ _ _ _) -> + Error.BadImports (toImportErrors env results imports problems) + + Err err -> + Error.BadSyntax err + ) + ) + ) + + SChanged ((Details.Local path time deps _ _ lastCompile) as local) source ((Src.Module _ _ _ _ imports _ _ _ _ _) as modul) docsNeed -> + Utils.readMVar resultDictDecoder resultsMVar + |> Task.bind + (\results -> + checkDeps root results deps lastCompile + |> Task.bind + (\depsStatus -> + case depsStatus of + DepsChange ifaces -> + compile env docsNeed local source ifaces modul + + DepsSame same cached -> + loadInterfaces root same cached + |> Task.bind + (\maybeLoaded -> + case maybeLoaded of + Nothing -> + Task.pure RBlocked + + Just ifaces -> + compile env docsNeed local source ifaces modul + ) + + DepsBlock -> + Task.pure RBlocked + + DepsNotFound problems -> + Task.pure <| + RProblem <| + Error.Module name path time source <| + Error.BadImports (toImportErrors env results imports problems) + ) + ) + + SBadImport importProblem -> + Task.pure (RNotFound importProblem) + + SBadSyntax path time source err -> + Task.pure <| + RProblem <| + Error.Module name path time source <| + Error.BadSyntax err + + SForeign home -> + case Utils.find ModuleName.toComparableCanonical (TypeCheck.Canonical home name) foreigns of + I.Public iface -> + Task.pure (RForeign iface) + + I.Private _ _ _ -> + crash <| "mistakenly seeing private interface for " ++ Pkg.toChars home ++ " " ++ name + + SKernel -> + Task.pure RKernel + + + +-- CHECK DEPS + + +type DepsStatus + = DepsChange (Dict String ModuleName.Raw I.Interface) + | DepsSame (List Dep) (List CDep) + | DepsBlock + | DepsNotFound (NE.Nonempty ( ModuleName.Raw, Import.Problem )) + + +checkDeps : FilePath -> ResultDict -> List ModuleName.Raw -> Details.BuildID -> Task Never DepsStatus +checkDeps root results deps lastCompile = + checkDepsHelp root results deps [] [] [] [] False 0 lastCompile + + +type alias Dep = + ( ModuleName.Raw, I.Interface ) + + +type alias CDep = + ( ModuleName.Raw, MVar CachedInterface ) + + +checkDepsHelp : FilePath -> ResultDict -> List ModuleName.Raw -> List Dep -> List Dep -> List CDep -> List ( ModuleName.Raw, Import.Problem ) -> Bool -> Details.BuildID -> Details.BuildID -> Task Never DepsStatus +checkDepsHelp root results deps new same cached importProblems isBlocked lastDepChange lastCompile = + case deps of + dep :: otherDeps -> + Utils.readMVar bResultDecoder (Utils.find identity dep results) + |> Task.bind + (\result -> + case result of + RNew (Details.Local _ _ _ _ lastChange _) iface _ _ -> + checkDepsHelp root results otherDeps (( dep, iface ) :: new) same cached importProblems isBlocked (max lastChange lastDepChange) lastCompile + + RSame (Details.Local _ _ _ _ lastChange _) iface _ _ -> + checkDepsHelp root results otherDeps new (( dep, iface ) :: same) cached importProblems isBlocked (max lastChange lastDepChange) lastCompile + + RCached _ lastChange mvar -> + checkDepsHelp root results otherDeps new same (( dep, mvar ) :: cached) importProblems isBlocked (max lastChange lastDepChange) lastCompile + + RNotFound prob -> + checkDepsHelp root results otherDeps new same cached (( dep, prob ) :: importProblems) True lastDepChange lastCompile + + RProblem _ -> + checkDepsHelp root results otherDeps new same cached importProblems True lastDepChange lastCompile + + RBlocked -> + checkDepsHelp root results otherDeps new same cached importProblems True lastDepChange lastCompile + + RForeign iface -> + checkDepsHelp root results otherDeps new (( dep, iface ) :: same) cached importProblems isBlocked lastDepChange lastCompile + + RKernel -> + checkDepsHelp root results otherDeps new same cached importProblems isBlocked lastDepChange lastCompile + ) + + [] -> + case List.reverse importProblems of + p :: ps -> + Task.pure <| DepsNotFound (NE.Nonempty p ps) + + [] -> + if isBlocked then + Task.pure <| DepsBlock + + else if List.isEmpty new && lastDepChange <= lastCompile then + Task.pure <| DepsSame same cached + + else + loadInterfaces root same cached + |> Task.bind + (\maybeLoaded -> + case maybeLoaded of + Nothing -> + Task.pure DepsBlock + + Just ifaces -> + Task.pure <| DepsChange <| Dict.union (Dict.fromList identity new) ifaces + ) + + + +-- TO IMPORT ERROR + + +toImportErrors : Env -> ResultDict -> List Src.Import -> NE.Nonempty ( ModuleName.Raw, Import.Problem ) -> NE.Nonempty Import.Error +toImportErrors (Env _ _ _ _ _ locals foreigns) results imports problems = + let + knownModules : EverySet.EverySet String ModuleName.Raw + knownModules = + EverySet.fromList identity + (List.concat + [ Dict.keys compare foreigns + , Dict.keys compare locals + , Dict.keys compare results + ] + ) + + unimportedModules : EverySet.EverySet String ModuleName.Raw + unimportedModules = + EverySet.diff knownModules (EverySet.fromList identity (List.map Src.getImportName imports)) + + regionDict : Dict String Name.Name A.Region + regionDict = + Dict.fromList identity (List.map (\(Src.Import ( _, A.At region name ) _ _) -> ( name, region )) imports) + + toError : ( Name.Name, Import.Problem ) -> Import.Error + toError ( name, problem ) = + Import.Error (Utils.find identity name regionDict) name unimportedModules problem + in + NE.map toError problems + + + +-- LOAD CACHED INTERFACES + + +loadInterfaces : FilePath -> List Dep -> List CDep -> Task Never (Maybe (Dict String ModuleName.Raw I.Interface)) +loadInterfaces root same cached = + Utils.listTraverse (fork maybeDepEncoder << loadInterface root) cached + |> Task.bind + (\loading -> + Utils.listTraverse (Utils.readMVar maybeDepDecoder) loading + |> Task.bind + (\maybeLoaded -> + case Utils.sequenceListMaybe maybeLoaded of + Nothing -> + Task.pure Nothing + + Just loaded -> + Task.pure <| Just <| Dict.union (Dict.fromList identity loaded) (Dict.fromList identity same) + ) + ) + + +loadInterface : FilePath -> CDep -> Task Never (Maybe Dep) +loadInterface root ( name, ciMvar ) = + Utils.takeMVar cachedInterfaceDecoder ciMvar + |> Task.bind + (\cachedInterface -> + case cachedInterface of + Corrupted -> + Utils.putMVar cachedInterfaceEncoder ciMvar cachedInterface + |> Task.fmap (\_ -> Nothing) + + Loaded iface -> + Utils.putMVar cachedInterfaceEncoder ciMvar cachedInterface + |> Task.fmap (\_ -> Just ( name, iface )) + + Unneeded -> + File.readBinary I.interfaceDecoder (Stuff.guidai root name) + |> Task.bind + (\maybeIface -> + case maybeIface of + Nothing -> + Utils.putMVar cachedInterfaceEncoder ciMvar Corrupted + |> Task.fmap (\_ -> Nothing) + + Just iface -> + Utils.putMVar cachedInterfaceEncoder ciMvar (Loaded iface) + |> Task.fmap (\_ -> Just ( name, iface )) + ) + ) + + + +-- CHECK PROJECT + + +checkMidpoint : MVar (Maybe Dependencies) -> Dict String ModuleName.Raw Status -> Task Never (Result Exit.BuildProjectProblem Dependencies) +checkMidpoint dmvar statuses = + case checkForCycles statuses of + Nothing -> + Utils.readMVar maybeDependenciesDecoder dmvar + |> Task.fmap + (\maybeForeigns -> + case maybeForeigns of + Nothing -> + Err Exit.BP_CannotLoadDependencies + + Just fs -> + Ok fs + ) + + Just (NE.Nonempty name names) -> + Utils.readMVar maybeDependenciesDecoder dmvar + |> Task.fmap (\_ -> Err (Exit.BP_Cycle name names)) + + +checkMidpointAndRoots : MVar (Maybe Dependencies) -> Dict String ModuleName.Raw Status -> NE.Nonempty RootStatus -> Task Never (Result Exit.BuildProjectProblem Dependencies) +checkMidpointAndRoots dmvar statuses sroots = + case checkForCycles statuses of + Nothing -> + case checkUniqueRoots statuses sroots of + Nothing -> + Utils.readMVar maybeDependenciesDecoder dmvar + |> Task.bind + (\maybeForeigns -> + case maybeForeigns of + Nothing -> + Task.pure (Err Exit.BP_CannotLoadDependencies) + + Just fs -> + Task.pure (Ok fs) + ) + + Just problem -> + Utils.readMVar maybeDependenciesDecoder dmvar + |> Task.fmap (\_ -> Err problem) + + Just (NE.Nonempty name names) -> + Utils.readMVar maybeDependenciesDecoder dmvar + |> Task.fmap (\_ -> Err (Exit.BP_Cycle name names)) + + + +-- CHECK FOR CYCLES + + +checkForCycles : Dict String ModuleName.Raw Status -> Maybe (NE.Nonempty ModuleName.Raw) +checkForCycles modules = + let + graph : List Node + graph = + Dict.foldr compare addToGraph [] modules + + sccs : List (Graph.SCC ModuleName.Raw) + sccs = + Graph.stronglyConnComp graph + in + checkForCyclesHelp sccs + + +checkForCyclesHelp : List (Graph.SCC ModuleName.Raw) -> Maybe (NE.Nonempty ModuleName.Raw) +checkForCyclesHelp sccs = + case sccs of + [] -> + Nothing + + scc :: otherSccs -> + case scc of + Graph.AcyclicSCC _ -> + checkForCyclesHelp otherSccs + + Graph.CyclicSCC [] -> + checkForCyclesHelp otherSccs + + Graph.CyclicSCC (m :: ms) -> + Just (NE.Nonempty m ms) + + +type alias Node = + ( ModuleName.Raw, ModuleName.Raw, List ModuleName.Raw ) + + +addToGraph : ModuleName.Raw -> Status -> List Node -> List Node +addToGraph name status graph = + let + dependencies : List ModuleName.Raw + dependencies = + case status of + SCached (Details.Local _ _ deps _ _ _) -> + deps + + SChanged (Details.Local _ _ deps _ _ _) _ _ _ -> + deps + + SBadImport _ -> + [] + + SBadSyntax _ _ _ _ -> + [] + + SForeign _ -> + [] + + SKernel -> + [] + in + ( name, name, dependencies ) :: graph + + + +-- CHECK UNIQUE ROOTS + + +checkUniqueRoots : Dict String ModuleName.Raw Status -> NE.Nonempty RootStatus -> Maybe Exit.BuildProjectProblem +checkUniqueRoots insides sroots = + let + outsidesDict : Dict String ModuleName.Raw (OneOrMore.OneOrMore FilePath) + outsidesDict = + Utils.mapFromListWith identity OneOrMore.more (List.filterMap rootStatusToNamePathPair (NE.toList sroots)) + in + case Utils.mapTraverseWithKeyResult identity compare checkOutside outsidesDict of + Err problem -> + Just problem + + Ok outsides -> + case Utils.sequenceDictResult_ identity compare (Utils.mapIntersectionWithKey identity compare checkInside outsides insides) of + Ok () -> + Nothing + + Err problem -> + Just problem + + +rootStatusToNamePathPair : RootStatus -> Maybe ( ModuleName.Raw, OneOrMore.OneOrMore FilePath ) +rootStatusToNamePathPair sroot = + case sroot of + SInside _ -> + Nothing + + SOutsideOk (Details.Local path _ _ _ _ _) _ modul -> + Just ( Src.getName modul, OneOrMore.one path ) + + SOutsideErr _ -> + Nothing + + +checkOutside : ModuleName.Raw -> OneOrMore.OneOrMore FilePath -> Result Exit.BuildProjectProblem FilePath +checkOutside name paths = + case OneOrMore.destruct NE.Nonempty paths of + NE.Nonempty p [] -> + Ok p + + NE.Nonempty p1 (p2 :: _) -> + Err (Exit.BP_RootNameDuplicate name p1 p2) + + +checkInside : ModuleName.Raw -> FilePath -> Status -> Result Exit.BuildProjectProblem () +checkInside name p1 status = + case status of + SCached (Details.Local p2 _ _ _ _ _) -> + Err (Exit.BP_RootNameDuplicate name p1 p2) + + SChanged (Details.Local p2 _ _ _ _ _) _ _ _ -> + Err (Exit.BP_RootNameDuplicate name p1 p2) + + SBadImport _ -> + Ok () + + SBadSyntax _ _ _ _ -> + Ok () + + SForeign _ -> + Ok () + + SKernel -> + Ok () + + + +-- COMPILE MODULE + + +compile : Env -> DocsNeed -> Details.Local -> String -> Dict String ModuleName.Raw I.Interface -> Src.Module -> Task Never BResult +compile (Env key root projectType _ buildID _ _) docsNeed (Details.Local path time deps main lastChange _) source ifaces modul = + let + pkg : Pkg.Name + pkg = + projectTypeToPkg projectType + in + Compile.compile pkg ifaces modul + |> Task.bind + (\result -> + case result of + Ok (Compile.Artifacts canonical annotations objects) -> + case makeDocs docsNeed canonical of + Err err -> + Task.pure <| + RProblem <| + Error.Module (Src.getName modul) path time source (Error.BadDocs err) + + Ok docs -> + let + name : Name.Name + name = + Src.getName modul + + iface : I.Interface + iface = + I.fromModule pkg canonical annotations + + guidai : String + guidai = + Stuff.guidai root name + in + File.writeBinary Opt.localGraphEncoder (Stuff.guidao root name) objects + |> Task.bind + (\_ -> + File.readBinary I.interfaceDecoder guidai + |> Task.bind + (\maybeOldi -> + case maybeOldi of + Just oldi -> + if oldi == iface then + -- iface should be fully forced by equality check + Reporting.report key Reporting.BDone + |> Task.fmap + (\_ -> + let + local : Details.Local + local = + Details.Local path time deps main lastChange buildID + in + RSame local iface objects docs + ) + + else + File.writeBinary I.interfaceEncoder guidai iface + |> Task.bind + (\_ -> + Reporting.report key Reporting.BDone + |> Task.fmap + (\_ -> + let + local : Details.Local + local = + Details.Local path time deps main buildID buildID + in + RNew local iface objects docs + ) + ) + + _ -> + -- iface may be lazy still + File.writeBinary I.interfaceEncoder guidai iface + |> Task.bind + (\_ -> + Reporting.report key Reporting.BDone + |> Task.fmap + (\_ -> + let + local : Details.Local + local = + Details.Local path time deps main buildID buildID + in + RNew local iface objects docs + ) + ) + ) + ) + + Err err -> + Task.pure <| + RProblem <| + Error.Module (Src.getName modul) path time source err + ) + + +projectTypeToPkg : Parse.ProjectType -> Pkg.Name +projectTypeToPkg projectType = + case projectType of + Parse.Package pkg -> + pkg + + Parse.Application -> + Pkg.dummyName + + + +-- WRITE DETAILS + + +writeDetails : FilePath -> Details.Details -> Dict String ModuleName.Raw BResult -> Task Never () +writeDetails root (Details.Details time outline buildID locals foreigns extras) results = + File.writeBinary Details.detailsEncoder (Stuff.details root) <| + Details.Details time outline buildID (Dict.foldr compare addNewLocal locals results) foreigns extras + + +addNewLocal : ModuleName.Raw -> BResult -> Dict String ModuleName.Raw Details.Local -> Dict String ModuleName.Raw Details.Local +addNewLocal name result locals = + case result of + RNew local _ _ _ -> + Dict.insert identity name local locals + + RSame local _ _ _ -> + Dict.insert identity name local locals + + RCached _ _ _ -> + locals + + RNotFound _ -> + locals + + RProblem _ -> + locals + + RBlocked -> + locals + + RForeign _ -> + locals + + RKernel -> + locals + + + +-- FINALIZE EXPOSED + + +finalizeExposed : FilePath -> DocsGoal docs -> NE.Nonempty ModuleName.Raw -> Dict String ModuleName.Raw BResult -> Task Never (Result Exit.BuildProblem docs) +finalizeExposed root docsGoal exposed results = + case List.foldr (addImportProblems results) [] (NE.toList exposed) of + p :: ps -> + Task.pure <| Err <| Exit.BuildProjectProblem (Exit.BP_MissingExposed (NE.Nonempty p ps)) + + [] -> + case Dict.foldr compare (\_ -> addErrors) [] results of + [] -> + Task.fmap Ok (finalizeDocs docsGoal results) + + e :: es -> + Task.pure <| Err <| Exit.BuildBadModules root e es + + +addErrors : BResult -> List Error.Module -> List Error.Module +addErrors result errors = + case result of + RNew _ _ _ _ -> + errors + + RSame _ _ _ _ -> + errors + + RCached _ _ _ -> + errors + + RNotFound _ -> + errors + + RProblem e -> + e :: errors + + RBlocked -> + errors + + RForeign _ -> + errors + + RKernel -> + errors + + +addImportProblems : Dict String ModuleName.Raw BResult -> ModuleName.Raw -> List ( ModuleName.Raw, Import.Problem ) -> List ( ModuleName.Raw, Import.Problem ) +addImportProblems results name problems = + case Utils.find identity name results of + RNew _ _ _ _ -> + problems + + RSame _ _ _ _ -> + problems + + RCached _ _ _ -> + problems + + RNotFound p -> + ( name, p ) :: problems + + RProblem _ -> + problems + + RBlocked -> + problems + + RForeign _ -> + problems + + RKernel -> + problems + + + +-- DOCS + + +type DocsGoal docs + = KeepDocs (Dict String ModuleName.Raw BResult -> docs) + | WriteDocs (Dict String ModuleName.Raw BResult -> Task Never docs) + | IgnoreDocs docs + + +keepDocs : DocsGoal (Dict String ModuleName.Raw Docs.Module) +keepDocs = + KeepDocs (Utils.mapMapMaybe identity compare toDocs) + + +writeDocs : FilePath -> DocsGoal () +writeDocs path = + WriteDocs (E.writeUgly path << Docs.encode << Utils.mapMapMaybe identity compare toDocs) + + +ignoreDocs : DocsGoal () +ignoreDocs = + IgnoreDocs () + + +type DocsNeed + = DocsNeed Bool + + +toDocsNeed : DocsGoal a -> DocsNeed +toDocsNeed goal = + case goal of + IgnoreDocs _ -> + DocsNeed False + + WriteDocs _ -> + DocsNeed True + + KeepDocs _ -> + DocsNeed True + + +makeDocs : DocsNeed -> Can.Module -> Result EDocs.Error (Maybe Docs.Module) +makeDocs (DocsNeed isNeeded) modul = + if isNeeded then + case Docs.fromModule modul of + Ok docs -> + Ok (Just docs) + + Err err -> + Err err + + else + Ok Nothing + + +finalizeDocs : DocsGoal docs -> Dict String ModuleName.Raw BResult -> Task Never docs +finalizeDocs goal results = + case goal of + KeepDocs f -> + Task.pure <| f results + + WriteDocs f -> + f results + + IgnoreDocs val -> + Task.pure val + + +toDocs : BResult -> Maybe Docs.Module +toDocs result = + case result of + RNew _ _ _ d -> + d + + RSame _ _ _ d -> + d + + RCached _ _ _ -> + Nothing + + RNotFound _ -> + Nothing + + RProblem _ -> + Nothing + + RBlocked -> + Nothing + + RForeign _ -> + Nothing + + RKernel -> + Nothing + + + +------------------------------------------------------------------------------- +------ NOW FOR SOME REPL STUFF ------------------------------------------------- +-------------------------------------------------------------------------------- +-- FROM REPL + + +type ReplArtifacts + = ReplArtifacts TypeCheck.Canonical (List Module) L.Localizer (Dict String Name.Name Can.Annotation) + + +fromRepl : FilePath -> Details.Details -> String -> Task Never (Result Exit.Repl ReplArtifacts) +fromRepl root details source = + makeEnv Reporting.ignorer root details + |> Task.bind + (\((Env _ _ projectType _ _ _ _) as env) -> + case Parse.fromByteString SV.Guida projectType source of + Err syntaxError -> + Task.pure <| Err <| Exit.ReplBadInput source <| Error.BadSyntax syntaxError + + Ok ((Src.Module _ _ _ _ imports _ _ _ _ _) as modul) -> + Details.loadInterfaces root details + |> Task.bind + (\dmvar -> + let + deps : List Name.Name + deps = + List.map Src.getImportName imports + in + Utils.newMVar statusDictEncoder Dict.empty + |> Task.bind + (\mvar -> + crawlDeps env mvar deps () + |> Task.bind + (\_ -> + Task.bind (Utils.mapTraverse identity compare (Utils.readMVar statusDecoder)) (Utils.readMVar statusDictDecoder mvar) + |> Task.bind + (\statuses -> + checkMidpoint dmvar statuses + |> Task.bind + (\midpoint -> + case midpoint of + Err problem -> + Task.pure <| Err <| Exit.ReplProjectProblem problem + + Ok foreigns -> + Utils.newEmptyMVar + |> Task.bind + (\rmvar -> + forkWithKey identity compare bResultEncoder (checkModule env foreigns rmvar) statuses + |> Task.bind + (\resultMVars -> + Utils.putMVar resultDictEncoder rmvar resultMVars + |> Task.bind + (\_ -> + Utils.mapTraverse identity compare (Utils.readMVar bResultDecoder) resultMVars + |> Task.bind + (\results -> + writeDetails root details results + |> Task.bind + (\_ -> + checkDeps root resultMVars deps 0 + |> Task.bind + (\depsStatus -> + finalizeReplArtifacts env source modul depsStatus resultMVars results + ) + ) + ) + ) + ) + ) + ) + ) + ) + ) + ) + ) + + +finalizeReplArtifacts : Env -> String -> Src.Module -> DepsStatus -> ResultDict -> Dict String ModuleName.Raw BResult -> Task Never (Result Exit.Repl ReplArtifacts) +finalizeReplArtifacts ((Env _ root projectType _ _ _ _) as env) source ((Src.Module _ _ _ _ imports _ _ _ _ _) as modul) depsStatus resultMVars results = + let + pkg : Pkg.Name + pkg = + projectTypeToPkg projectType + + compileInput : Dict String ModuleName.Raw I.Interface -> Task Never (Result Exit.Repl ReplArtifacts) + compileInput ifaces = + Compile.compile pkg ifaces modul + |> Task.fmap + (\result -> + case result of + Ok (Compile.Artifacts ((Can.Module name _ _ _ _ _ _ _) as canonical) annotations objects) -> + let + h : TypeCheck.Canonical + h = + name + + m : Module + m = + Fresh (Src.getName modul) (I.fromModule pkg canonical annotations) objects + + ms : List Module + ms = + Dict.foldr compare addInside [] results + in + Ok <| ReplArtifacts h (m :: ms) (L.fromModule modul) annotations + + Err errors -> + Err <| Exit.ReplBadInput source errors + ) + in + case depsStatus of + DepsChange ifaces -> + compileInput ifaces + + DepsSame same cached -> + loadInterfaces root same cached + |> Task.bind + (\maybeLoaded -> + case maybeLoaded of + Just ifaces -> + compileInput ifaces + + Nothing -> + Task.pure <| Err <| Exit.ReplBadCache + ) + + DepsBlock -> + case Dict.foldr compare (\_ -> addErrors) [] results of + [] -> + Task.pure <| Err <| Exit.ReplBlocked + + e :: es -> + Task.pure <| Err <| Exit.ReplBadLocalDeps root e es + + DepsNotFound problems -> + Task.pure <| + Err <| + Exit.ReplBadInput source <| + Error.BadImports <| + toImportErrors env resultMVars imports problems + + + +-------------------------------------------------------------------------------- +-------------------------------------------------------------------------------- +------ AFTER THIS, EVERYTHING IS ABOUT HANDLING MODULES GIVEN BY FILEPATH ------ +-------------------------------------------------------------------------------- +-------------------------------------------------------------------------------- +-- FIND ROOT + + +type RootLocation + = LInside ModuleName.Raw + | LOutside FilePath + + +findRoots : Env -> NE.Nonempty FilePath -> Task Never (Result Exit.BuildProjectProblem (NE.Nonempty RootLocation)) +findRoots env paths = + Utils.nonEmptyListTraverse (fork resultBuildProjectProblemRootInfoEncoder << getRootInfo env) paths + |> Task.bind + (\mvars -> + Utils.nonEmptyListTraverse (Utils.readMVar resultBuildProjectProblemRootInfoDecoder) mvars + |> Task.bind + (\einfos -> + Task.pure (Result.andThen checkRoots (Utils.sequenceNonemptyListResult einfos)) + ) + ) + + +checkRoots : NE.Nonempty RootInfo -> Result Exit.BuildProjectProblem (NE.Nonempty RootLocation) +checkRoots infos = + let + toOneOrMore : RootInfo -> ( FilePath, OneOrMore.OneOrMore RootInfo ) + toOneOrMore ((RootInfo absolute _ _) as loc) = + ( absolute, OneOrMore.one loc ) + + fromOneOrMore : RootInfo -> List RootInfo -> Result Exit.BuildProjectProblem () + fromOneOrMore (RootInfo _ relative _) locs = + case locs of + [] -> + Ok () + + (RootInfo _ relative2 _) :: _ -> + Err (Exit.BP_MainPathDuplicate relative relative2) + in + Result.map (\_ -> NE.map (\(RootInfo _ _ location) -> location) infos) <| + Utils.mapTraverseResult identity compare (OneOrMore.destruct fromOneOrMore) <| + Utils.mapFromListWith identity OneOrMore.more <| + List.map toOneOrMore (NE.toList infos) + + + +-- ROOT INFO + + +type RootInfo + = RootInfo FilePath FilePath RootLocation + + +getRootInfo : Env -> FilePath -> Task Never (Result Exit.BuildProjectProblem RootInfo) +getRootInfo env path = + File.exists path + |> Task.bind + (\exists -> + if exists then + Task.bind (getRootInfoHelp env path) (Utils.dirCanonicalizePath path) + + else + Task.pure (Err (Exit.BP_PathUnknown path)) + ) + + +getRootInfoHelp : Env -> FilePath -> FilePath -> Task Never (Result Exit.BuildProjectProblem RootInfo) +getRootInfoHelp (Env _ _ _ srcDirs _ _ _) path absolutePath = + let + ( dirs, file ) = + Utils.fpSplitFileName absolutePath + + ( final, ext ) = + Utils.fpSplitExtension file + in + if List.member ext [ ".guida", ".elm" ] then + let + absoluteSegments : List String + absoluteSegments = + Utils.fpSplitDirectories dirs ++ [ final ] + in + case List.filterMap (isInsideSrcDirByPath absoluteSegments) srcDirs of + [] -> + Task.pure <| Ok <| RootInfo absolutePath path (LOutside path) + + [ ( _, Ok names ) ] -> + let + name : String + name = + String.join "." names + in + Utils.filterM (isInsideSrcDirByName names ext) srcDirs + |> Task.bind + (\matchingDirs -> + case matchingDirs of + d1 :: d2 :: _ -> + let + p1 : FilePath + p1 = + addRelative d1 (Utils.fpJoinPath names ++ ext) + + p2 : FilePath + p2 = + addRelative d2 (Utils.fpJoinPath names ++ ext) + in + Task.pure <| Err <| Exit.BP_RootNameDuplicate name p1 p2 + + _ -> + Task.pure <| Ok <| RootInfo absolutePath path (LInside name) + ) + + [ ( s, Err names ) ] -> + Task.pure <| Err <| Exit.BP_RootNameInvalid path s names + + ( s1, _ ) :: ( s2, _ ) :: _ -> + Task.pure <| Err <| Exit.BP_WithAmbiguousSrcDir path s1 s2 + + else + Task.pure <| Err <| Exit.BP_WithBadExtension path + + +isInsideSrcDirByName : List String -> String -> AbsoluteSrcDir -> Task Never Bool +isInsideSrcDirByName names extension srcDir = + File.exists (addRelative srcDir (Utils.fpJoinPath names ++ extension)) + + +isInsideSrcDirByPath : List String -> AbsoluteSrcDir -> Maybe ( FilePath, Result (List String) (List String) ) +isInsideSrcDirByPath segments (AbsoluteSrcDir srcDir) = + dropPrefix (Utils.fpSplitDirectories srcDir) segments + |> Maybe.map + (\names -> + if List.all isGoodName names then + ( srcDir, Ok names ) + + else + ( srcDir, Err names ) + ) + + +isGoodName : String -> Bool +isGoodName name = + case String.toList name of + [] -> + False + + char :: chars -> + Char.isUpper char && List.all (\c -> Char.isAlphaNum c || c == '_') chars + + + +-- INVARIANT: Dir.canonicalizePath has been run on both inputs + + +dropPrefix : List FilePath -> List FilePath -> Maybe (List FilePath) +dropPrefix roots paths = + case roots of + [] -> + Just paths + + r :: rs -> + case paths of + [] -> + Nothing + + p :: ps -> + if r == p then + dropPrefix rs ps + + else + Nothing + + + +-- CRAWL ROOTS + + +type RootStatus + = SInside ModuleName.Raw + | SOutsideOk Details.Local String Src.Module + | SOutsideErr Error.Module + + +crawlRoot : Env -> MVar StatusDict -> RootLocation -> Task Never RootStatus +crawlRoot ((Env _ _ projectType _ buildID _ _) as env) mvar root = + case root of + LInside name -> + Utils.newEmptyMVar + |> Task.bind + (\statusMVar -> + Utils.takeMVar statusDictDecoder mvar + |> Task.bind + (\statusDict -> + Utils.putMVar statusDictEncoder mvar (Dict.insert identity name statusMVar statusDict) + |> Task.bind + (\_ -> + Task.bind (Utils.putMVar statusEncoder statusMVar) (crawlModule env mvar (DocsNeed False) name) + |> Task.fmap (\_ -> SInside name) + ) + ) + ) + + LOutside path -> + File.getTime path + |> Task.bind + (\time -> + File.readUtf8 path + |> Task.bind + (\source -> + case Parse.fromByteString (SV.fileSyntaxVersion path) projectType source of + Ok ((Src.Module _ _ _ _ imports values _ _ _ _) as modul) -> + let + deps : List Name.Name + deps = + List.map Src.getImportName imports + + local : Details.Local + local = + Details.Local path time deps (List.any isMain values) buildID buildID + in + crawlDeps env mvar deps (SOutsideOk local source modul) + + Err syntaxError -> + Task.pure <| + SOutsideErr <| + Error.Module "???" path time source (Error.BadSyntax syntaxError) + ) + ) + + + +-- CHECK ROOTS + + +type RootResult + = RInside ModuleName.Raw + | ROutsideOk ModuleName.Raw I.Interface Opt.LocalGraph + | ROutsideErr Error.Module + | ROutsideBlocked + + +checkRoot : Env -> ResultDict -> RootStatus -> Task Never RootResult +checkRoot ((Env _ root _ _ _ _ _) as env) results rootStatus = + case rootStatus of + SInside name -> + Task.pure (RInside name) + + SOutsideErr err -> + Task.pure (ROutsideErr err) + + SOutsideOk ((Details.Local path time deps _ _ lastCompile) as local) source ((Src.Module _ _ _ _ imports _ _ _ _ _) as modul) -> + checkDeps root results deps lastCompile + |> Task.bind + (\depsStatus -> + case depsStatus of + DepsChange ifaces -> + compileOutside env local source ifaces modul + + DepsSame same cached -> + loadInterfaces root same cached + |> Task.bind + (\maybeLoaded -> + case maybeLoaded of + Nothing -> + Task.pure ROutsideBlocked + + Just ifaces -> + compileOutside env local source ifaces modul + ) + + DepsBlock -> + Task.pure ROutsideBlocked + + DepsNotFound problems -> + Task.pure <| + ROutsideErr <| + Error.Module (Src.getName modul) path time source <| + Error.BadImports (toImportErrors env results imports problems) + ) + + +compileOutside : Env -> Details.Local -> String -> Dict String ModuleName.Raw I.Interface -> Src.Module -> Task Never RootResult +compileOutside (Env key _ projectType _ _ _ _) (Details.Local path time _ _ _ _) source ifaces modul = + let + pkg : Pkg.Name + pkg = + projectTypeToPkg projectType + + name : Name.Name + name = + Src.getName modul + in + Compile.compile pkg ifaces modul + |> Task.bind + (\result -> + case result of + Ok (Compile.Artifacts canonical annotations objects) -> + Reporting.report key Reporting.BDone + |> Task.fmap (\_ -> ROutsideOk name (I.fromModule pkg canonical annotations) objects) + + Err errors -> + Task.pure <| ROutsideErr <| Error.Module name path time source errors + ) + + + +-- TO ARTIFACTS + + +type Root + = Inside ModuleName.Raw + | Outside ModuleName.Raw I.Interface Opt.LocalGraph + + +toArtifacts : Env -> Dependencies -> Dict String ModuleName.Raw BResult -> NE.Nonempty RootResult -> Result Exit.BuildProblem Artifacts +toArtifacts (Env _ root projectType _ _ _ _) foreigns results rootResults = + case gatherProblemsOrMains results rootResults of + Err (NE.Nonempty e es) -> + Err (Exit.BuildBadModules root e es) + + Ok roots -> + Ok <| + Artifacts (projectTypeToPkg projectType) foreigns roots <| + Dict.foldr compare addInside (NE.foldr addOutside [] rootResults) results + + +gatherProblemsOrMains : Dict String ModuleName.Raw BResult -> NE.Nonempty RootResult -> Result (NE.Nonempty Error.Module) (NE.Nonempty Root) +gatherProblemsOrMains results (NE.Nonempty rootResult rootResults) = + let + addResult : RootResult -> ( List Error.Module, List Root ) -> ( List Error.Module, List Root ) + addResult result ( es, roots ) = + case result of + RInside n -> + ( es, Inside n :: roots ) + + ROutsideOk n i o -> + ( es, Outside n i o :: roots ) + + ROutsideErr e -> + ( e :: es, roots ) + + ROutsideBlocked -> + ( es, roots ) + + errors : List Error.Module + errors = + Dict.foldr compare (\_ -> addErrors) [] results + in + case ( rootResult, List.foldr addResult ( errors, [] ) rootResults ) of + ( RInside n, ( [], ms ) ) -> + Ok (NE.Nonempty (Inside n) ms) + + ( RInside _, ( e :: es, _ ) ) -> + Err (NE.Nonempty e es) + + ( ROutsideOk n i o, ( [], ms ) ) -> + Ok (NE.Nonempty (Outside n i o) ms) + + ( ROutsideOk _ _ _, ( e :: es, _ ) ) -> + Err (NE.Nonempty e es) + + ( ROutsideErr e, ( es, _ ) ) -> + Err (NE.Nonempty e es) + + ( ROutsideBlocked, ( [], _ ) ) -> + crash "seems like guida-stuff/ is corrupted" + + ( ROutsideBlocked, ( e :: es, _ ) ) -> + Err (NE.Nonempty e es) + + +addInside : ModuleName.Raw -> BResult -> List Module -> List Module +addInside name result modules = + case result of + RNew _ iface objs _ -> + Fresh name iface objs :: modules + + RSame _ iface objs _ -> + Fresh name iface objs :: modules + + RCached main _ mvar -> + Cached name main mvar :: modules + + RNotFound _ -> + crash (badInside name) + + RProblem _ -> + crash (badInside name) + + RBlocked -> + crash (badInside name) + + RForeign _ -> + modules + + RKernel -> + modules + + +badInside : ModuleName.Raw -> String +badInside name = + "Error from `" ++ name ++ "` should have been reported already." + + +addOutside : RootResult -> List Module -> List Module +addOutside root modules = + case root of + RInside _ -> + modules + + ROutsideOk name iface objs -> + Fresh name iface objs :: modules + + ROutsideErr _ -> + modules + + ROutsideBlocked -> + modules + + + +-- ENCODERS and DECODERS + + +dictRawMVarBResultEncoder : Dict String ModuleName.Raw (MVar BResult) -> BE.Encoder +dictRawMVarBResultEncoder = + BE.assocListDict compare ModuleName.rawEncoder Utils.mVarEncoder + + +bResultEncoder : BResult -> BE.Encoder +bResultEncoder bResult = + case bResult of + RNew local iface objects docs -> + BE.sequence + [ BE.unsignedInt8 0 + , Details.localEncoder local + , I.interfaceEncoder iface + , Opt.localGraphEncoder objects + , BE.maybe Docs.bytesModuleEncoder docs + ] + + RSame local iface objects docs -> + BE.sequence + [ BE.unsignedInt8 1 + , Details.localEncoder local + , I.interfaceEncoder iface + , Opt.localGraphEncoder objects + , BE.maybe Docs.bytesModuleEncoder docs + ] + + RCached main lastChange (MVar ref) -> + BE.sequence + [ BE.unsignedInt8 2 + , BE.bool main + , BE.int lastChange + , BE.int ref + ] + + RNotFound importProblem -> + BE.sequence + [ BE.unsignedInt8 3 + , Import.problemEncoder importProblem + ] + + RProblem e -> + BE.sequence + [ BE.unsignedInt8 4 + , Error.moduleEncoder e + ] + + RBlocked -> + BE.unsignedInt8 5 + + RForeign iface -> + BE.sequence + [ BE.unsignedInt8 6 + , I.interfaceEncoder iface + ] + + RKernel -> + BE.unsignedInt8 7 + + +bResultDecoder : BD.Decoder BResult +bResultDecoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.map4 RNew + Details.localDecoder + I.interfaceDecoder + Opt.localGraphDecoder + (BD.maybe Docs.bytesModuleDecoder) + + 1 -> + BD.map4 RSame + Details.localDecoder + I.interfaceDecoder + Opt.localGraphDecoder + (BD.maybe Docs.bytesModuleDecoder) + + 2 -> + BD.map3 RCached + BD.bool + BD.int + (BD.map MVar BD.int) + + 3 -> + BD.map RNotFound Import.problemDecoder + + 4 -> + BD.map RProblem Error.moduleDecoder + + 5 -> + BD.succeed RBlocked + + 6 -> + BD.map RForeign I.interfaceDecoder + + 7 -> + BD.succeed RKernel + + _ -> + BD.fail + ) + + +statusDictEncoder : StatusDict -> BE.Encoder +statusDictEncoder statusDict = + BE.assocListDict compare ModuleName.rawEncoder Utils.mVarEncoder statusDict + + +statusDictDecoder : BD.Decoder StatusDict +statusDictDecoder = + BD.assocListDict identity ModuleName.rawDecoder Utils.mVarDecoder + + +statusEncoder : Status -> BE.Encoder +statusEncoder status = + case status of + SCached local -> + BE.sequence + [ BE.unsignedInt8 0 + , Details.localEncoder local + ] + + SChanged local iface objects docs -> + BE.sequence + [ BE.unsignedInt8 1 + , Details.localEncoder local + , BE.string iface + , Src.moduleEncoder objects + , docsNeedEncoder docs + ] + + SBadImport importProblem -> + BE.sequence + [ BE.unsignedInt8 2 + , Import.problemEncoder importProblem + ] + + SBadSyntax path time source err -> + BE.sequence + [ BE.unsignedInt8 3 + , BE.string path + , File.timeEncoder time + , BE.string source + , Syntax.errorEncoder err + ] + + SForeign home -> + BE.sequence + [ BE.unsignedInt8 4 + , Pkg.nameEncoder home + ] + + SKernel -> + BE.unsignedInt8 5 + + +statusDecoder : BD.Decoder Status +statusDecoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.map SCached Details.localDecoder + + 1 -> + BD.map4 SChanged + Details.localDecoder + BD.string + Src.moduleDecoder + docsNeedDecoder + + 2 -> + BD.map SBadImport Import.problemDecoder + + 3 -> + BD.map4 SBadSyntax + BD.string + File.timeDecoder + BD.string + Syntax.errorDecoder + + 4 -> + BD.map SForeign Pkg.nameDecoder + + 5 -> + BD.succeed SKernel + + _ -> + BD.fail + ) + + +rootStatusEncoder : RootStatus -> BE.Encoder +rootStatusEncoder rootStatus = + case rootStatus of + SInside name -> + BE.sequence + [ BE.unsignedInt8 0 + , ModuleName.rawEncoder name + ] + + SOutsideOk local source modul -> + BE.sequence + [ BE.unsignedInt8 1 + , Details.localEncoder local + , BE.string source + , Src.moduleEncoder modul + ] + + SOutsideErr err -> + BE.sequence + [ BE.unsignedInt8 2 + , Error.moduleEncoder err + ] + + +rootStatusDecoder : BD.Decoder RootStatus +rootStatusDecoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.map SInside ModuleName.rawDecoder + + 1 -> + BD.map3 SOutsideOk + Details.localDecoder + BD.string + Src.moduleDecoder + + 2 -> + BD.map SOutsideErr Error.moduleDecoder + + _ -> + BD.fail + ) + + +resultDictEncoder : ResultDict -> BE.Encoder +resultDictEncoder = + BE.assocListDict compare ModuleName.rawEncoder Utils.mVarEncoder + + +resultDictDecoder : BD.Decoder ResultDict +resultDictDecoder = + BD.assocListDict identity ModuleName.rawDecoder Utils.mVarDecoder + + +rootResultEncoder : RootResult -> BE.Encoder +rootResultEncoder rootResult = + case rootResult of + RInside name -> + BE.sequence + [ BE.unsignedInt8 0 + , ModuleName.rawEncoder name + ] + + ROutsideOk name iface objs -> + BE.sequence + [ BE.unsignedInt8 1 + , ModuleName.rawEncoder name + , I.interfaceEncoder iface + , Opt.localGraphEncoder objs + ] + + ROutsideErr err -> + BE.sequence + [ BE.unsignedInt8 2 + , Error.moduleEncoder err + ] + + ROutsideBlocked -> + BE.unsignedInt8 3 + + +rootResultDecoder : BD.Decoder RootResult +rootResultDecoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.map RInside ModuleName.rawDecoder + + 1 -> + BD.map3 ROutsideOk + ModuleName.rawDecoder + I.interfaceDecoder + Opt.localGraphDecoder + + 2 -> + BD.map ROutsideErr Error.moduleDecoder + + 3 -> + BD.succeed ROutsideBlocked + + _ -> + BD.fail + ) + + +maybeDepEncoder : Maybe Dep -> BE.Encoder +maybeDepEncoder = + BE.maybe depEncoder + + +maybeDepDecoder : BD.Decoder (Maybe Dep) +maybeDepDecoder = + BD.maybe depDecoder + + +depEncoder : Dep -> BE.Encoder +depEncoder = + BE.jsonPair ModuleName.rawEncoder I.interfaceEncoder + + +depDecoder : BD.Decoder Dep +depDecoder = + BD.jsonPair ModuleName.rawDecoder I.interfaceDecoder + + +maybeDependenciesDecoder : BD.Decoder (Maybe Dependencies) +maybeDependenciesDecoder = + BD.maybe (BD.assocListDict ModuleName.toComparableCanonical ModuleName.canonicalDecoder I.dependencyInterfaceDecoder) + + +resultBuildProjectProblemRootInfoEncoder : Result Exit.BuildProjectProblem RootInfo -> BE.Encoder +resultBuildProjectProblemRootInfoEncoder = + BE.result Exit.buildProjectProblemEncoder rootInfoEncoder + + +resultBuildProjectProblemRootInfoDecoder : BD.Decoder (Result Exit.BuildProjectProblem RootInfo) +resultBuildProjectProblemRootInfoDecoder = + BD.result Exit.buildProjectProblemDecoder rootInfoDecoder + + +cachedInterfaceEncoder : CachedInterface -> BE.Encoder +cachedInterfaceEncoder cachedInterface = + case cachedInterface of + Unneeded -> + BE.unsignedInt8 0 + + Loaded iface -> + BE.sequence + [ BE.unsignedInt8 1 + , I.interfaceEncoder iface + ] + + Corrupted -> + BE.unsignedInt8 2 + + +cachedInterfaceDecoder : BD.Decoder CachedInterface +cachedInterfaceDecoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.succeed Unneeded + + 1 -> + BD.map Loaded I.interfaceDecoder + + 2 -> + BD.succeed Corrupted + + _ -> + BD.fail + ) + + +docsNeedEncoder : DocsNeed -> BE.Encoder +docsNeedEncoder (DocsNeed isNeeded) = + BE.bool isNeeded + + +docsNeedDecoder : BD.Decoder DocsNeed +docsNeedDecoder = + BD.map DocsNeed BD.bool + + +artifactsEncoder : Artifacts -> BE.Encoder +artifactsEncoder (Artifacts pkg ifaces roots modules) = + BE.sequence + [ Pkg.nameEncoder pkg + , dependenciesEncoder ifaces + , BE.nonempty rootEncoder roots + , BE.list moduleEncoder modules + ] + + +artifactsDecoder : BD.Decoder Artifacts +artifactsDecoder = + BD.map4 Artifacts + Pkg.nameDecoder + dependenciesDecoder + (BD.nonempty rootDecoder) + (BD.list moduleDecoder) + + +dependenciesEncoder : Dependencies -> BE.Encoder +dependenciesEncoder = + BE.assocListDict ModuleName.compareCanonical ModuleName.canonicalEncoder I.dependencyInterfaceEncoder + + +dependenciesDecoder : BD.Decoder Dependencies +dependenciesDecoder = + BD.assocListDict ModuleName.toComparableCanonical ModuleName.canonicalDecoder I.dependencyInterfaceDecoder + + +rootEncoder : Root -> BE.Encoder +rootEncoder root = + case root of + Inside name -> + BE.sequence + [ BE.unsignedInt8 0 + , ModuleName.rawEncoder name + ] + + Outside name main mvar -> + BE.sequence + [ BE.unsignedInt8 1 + , ModuleName.rawEncoder name + , I.interfaceEncoder main + , Opt.localGraphEncoder mvar + ] + + +rootDecoder : BD.Decoder Root +rootDecoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.map Inside ModuleName.rawDecoder + + 1 -> + BD.map3 Outside + ModuleName.rawDecoder + I.interfaceDecoder + Opt.localGraphDecoder + + _ -> + BD.fail + ) + + +moduleEncoder : Module -> BE.Encoder +moduleEncoder modul = + case modul of + Fresh name iface objs -> + BE.sequence + [ BE.unsignedInt8 0 + , ModuleName.rawEncoder name + , I.interfaceEncoder iface + , Opt.localGraphEncoder objs + ] + + Cached name main mvar -> + BE.sequence + [ BE.unsignedInt8 1 + , ModuleName.rawEncoder name + , BE.bool main + , Utils.mVarEncoder mvar + ] + + +moduleDecoder : BD.Decoder Module +moduleDecoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.map3 Fresh + ModuleName.rawDecoder + I.interfaceDecoder + Opt.localGraphDecoder + + 1 -> + BD.map3 Cached + ModuleName.rawDecoder + BD.bool + Utils.mVarDecoder + + _ -> + BD.fail + ) + + +rootInfoEncoder : RootInfo -> BE.Encoder +rootInfoEncoder (RootInfo absolute relative location) = + BE.sequence + [ BE.string absolute + , BE.string relative + , rootLocationEncoder location + ] + + +rootInfoDecoder : BD.Decoder RootInfo +rootInfoDecoder = + BD.map3 RootInfo + BD.string + BD.string + rootLocationDecoder + + +rootLocationEncoder : RootLocation -> BE.Encoder +rootLocationEncoder rootLocation = + case rootLocation of + LInside name -> + BE.sequence + [ BE.unsignedInt8 0 + , ModuleName.rawEncoder name + ] + + LOutside path -> + BE.sequence + [ BE.unsignedInt8 1 + , BE.string path + ] + + +rootLocationDecoder : BD.Decoder RootLocation +rootLocationDecoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.map LInside ModuleName.rawDecoder + + 1 -> + BD.map LOutside BD.string + + _ -> + BD.fail + ) diff --git a/src/Builder/Deps/Bump.elm b/src/Builder/Deps/Bump.elm new file mode 100644 index 0000000000..c35f5e07b7 --- /dev/null +++ b/src/Builder/Deps/Bump.elm @@ -0,0 +1,41 @@ +module Builder.Deps.Bump exposing (getPossibilities) + +import Builder.Deps.Registry exposing (KnownVersions(..)) +import Compiler.Elm.Magnitude as M +import Compiler.Elm.Version as V +import List.Extra +import Utils.Main as Utils + + + +-- GET POSSIBILITIES + + +getPossibilities : KnownVersions -> List ( V.Version, V.Version, M.Magnitude ) +getPossibilities (KnownVersions latest previous) = + let + allVersions : List V.Version + allVersions = + List.reverse (latest :: previous) + + minorPoints : List V.Version + minorPoints = + List.filterMap List.Extra.last (Utils.listGroupBy sameMajor allVersions) + + patchPoints : List V.Version + patchPoints = + List.filterMap List.Extra.last (Utils.listGroupBy sameMinor allVersions) + in + ( latest, V.bumpMajor latest, M.MAJOR ) + :: List.map (\v -> ( v, V.bumpMinor v, M.MINOR )) minorPoints + ++ List.map (\v -> ( v, V.bumpPatch v, M.PATCH )) patchPoints + + +sameMajor : V.Version -> V.Version -> Bool +sameMajor (V.Version major1 _ _) (V.Version major2 _ _) = + major1 == major2 + + +sameMinor : V.Version -> V.Version -> Bool +sameMinor (V.Version major1 minor1 _) (V.Version major2 minor2 _) = + major1 == major2 && minor1 == minor2 diff --git a/src/Builder/Deps/Diff.elm b/src/Builder/Deps/Diff.elm new file mode 100644 index 0000000000..c19b5b04e2 --- /dev/null +++ b/src/Builder/Deps/Diff.elm @@ -0,0 +1,441 @@ +module Builder.Deps.Diff exposing + ( Changes(..) + , ModuleChanges(..) + , PackageChanges(..) + , bump + , diff + , getDocs + , moduleChangeMagnitude + , toMagnitude + ) + +import Builder.Deps.Website as Website +import Builder.File as File +import Builder.Http as Http +import Builder.Reporting.Exit as Exit exposing (DocsProblem(..)) +import Builder.Stuff as Stuff +import Compiler.Data.Name as Name +import Compiler.Elm.Compiler.Type as Type +import Compiler.Elm.Docs as Docs +import Compiler.Elm.Magnitude as M +import Compiler.Elm.ModuleName as ModuleName +import Compiler.Elm.Package as Pkg +import Compiler.Elm.Version as V exposing (Version) +import Compiler.Json.Decode as D +import Data.Map as Dict exposing (Dict) +import Data.Set as EverySet +import List +import Task exposing (Task) +import Utils.Main as Utils +import Utils.Task.Extra as Task + + +type PackageChanges + = PackageChanges (List ModuleName.Raw) (Dict String ModuleName.Raw ModuleChanges) (List ModuleName.Raw) + + +type ModuleChanges + = ModuleChanges (Changes String Name.Name Docs.Union) (Changes String Name.Name Docs.Alias) (Changes String Name.Name Docs.Value) (Changes String Name.Name Docs.Binop) + + +type Changes c k v + = Changes (Dict c k v) (Dict c k ( v, v )) (Dict c k v) + + +getChanges : (k -> comparable) -> (k -> k -> Order) -> (v -> v -> Bool) -> Dict comparable k v -> Dict comparable k v -> Changes comparable k v +getChanges toComparable keyComparison isEquivalent old new = + let + overlap : Dict comparable k ( v, v ) + overlap = + Utils.mapIntersectionWith toComparable keyComparison Tuple.pair old new + + changed : Dict comparable k ( v, v ) + changed = + Dict.filter (\_ ( v1, v2 ) -> not (isEquivalent v1 v2)) overlap + in + Changes + (Dict.diff new old) + changed + (Dict.diff old new) + + + +-- DIFF + + +diff : Docs.Documentation -> Docs.Documentation -> PackageChanges +diff oldDocs newDocs = + let + filterOutPatches : Dict comparable a ModuleChanges -> Dict comparable a ModuleChanges + filterOutPatches chngs = + Dict.filter (\_ chng -> moduleChangeMagnitude chng /= M.PATCH) chngs + + (Changes added changed removed) = + getChanges identity compare (\_ _ -> False) oldDocs newDocs + in + PackageChanges + (Dict.keys compare added) + (filterOutPatches (Dict.map (\_ -> diffModule) changed)) + (Dict.keys compare removed) + + +diffModule : ( Docs.Module, Docs.Module ) -> ModuleChanges +diffModule ( Docs.Module _ _ u1 a1 v1 b1, Docs.Module _ _ u2 a2 v2 b2 ) = + ModuleChanges + (getChanges identity compare isEquivalentUnion u1 u2) + (getChanges identity compare isEquivalentAlias a1 a2) + (getChanges identity compare isEquivalentValue v1 v2) + (getChanges identity compare isEquivalentBinop b1 b2) + + + +-- EQUIVALENCE + + +isEquivalentUnion : Docs.Union -> Docs.Union -> Bool +isEquivalentUnion (Docs.Union oldComment oldVars oldCtors) (Docs.Union newComment newVars newCtors) = + let + equiv : List Type.Type -> List Type.Type -> Bool + equiv oldTypes newTypes = + let + allEquivalent : List Bool + allEquivalent = + List.map2 + isEquivalentAlias + (List.map (Docs.Alias oldComment oldVars) oldTypes) + (List.map (Docs.Alias newComment newVars) newTypes) + in + (List.length oldTypes == List.length newTypes) + && List.all identity allEquivalent + in + (List.length oldCtors == List.length newCtors) + && List.all identity (List.map2 (==) (List.map Tuple.first oldCtors) (List.map Tuple.first newCtors)) + && List.all identity (Dict.values compare (Utils.mapIntersectionWith identity compare equiv (Dict.fromList identity oldCtors) (Dict.fromList identity newCtors))) + + +isEquivalentAlias : Docs.Alias -> Docs.Alias -> Bool +isEquivalentAlias (Docs.Alias _ oldVars oldType) (Docs.Alias _ newVars newType) = + case diffType oldType newType of + Nothing -> + False + + Just renamings -> + (List.length oldVars == List.length newVars) + && isEquivalentRenaming (List.map2 Tuple.pair oldVars newVars ++ renamings) + + +isEquivalentValue : Docs.Value -> Docs.Value -> Bool +isEquivalentValue (Docs.Value c1 t1) (Docs.Value c2 t2) = + isEquivalentAlias (Docs.Alias c1 [] t1) (Docs.Alias c2 [] t2) + + +isEquivalentBinop : Docs.Binop -> Docs.Binop -> Bool +isEquivalentBinop (Docs.Binop c1 t1 a1 p1) (Docs.Binop c2 t2 a2 p2) = + isEquivalentAlias (Docs.Alias c1 [] t1) (Docs.Alias c2 [] t2) + && (a1 == a2) + && (p1 == p2) + + + +-- DIFF TYPES + + +diffType : Type.Type -> Type.Type -> Maybe (List ( Name.Name, Name.Name )) +diffType oldType newType = + case ( oldType, newType ) of + ( Type.Var oldName, Type.Var newName ) -> + Just [ ( oldName, newName ) ] + + ( Type.Lambda a b, Type.Lambda a_ b_ ) -> + Maybe.map2 (++) (diffType a a_) (diffType b b_) + + ( Type.Type oldName oldArgs, Type.Type newName newArgs ) -> + if not (isSameName oldName newName) || List.length oldArgs /= List.length newArgs then + Nothing + + else + Maybe.map List.concat (Utils.zipWithM diffType oldArgs newArgs) + + ( Type.Record fields maybeExt, Type.Record fields_ maybeExt_ ) -> + case ( maybeExt, maybeExt_ ) of + ( Nothing, Just _ ) -> + Nothing + + ( Just _, Nothing ) -> + Nothing + + ( Nothing, Nothing ) -> + diffFields fields fields_ + + ( Just oldExt, Just newExt ) -> + Maybe.map ((::) ( oldExt, newExt )) (diffFields fields fields_) + + ( Type.Unit, Type.Unit ) -> + Just [] + + ( Type.Tuple a b cs, Type.Tuple x y zs ) -> + if List.length cs /= List.length zs then + Nothing + + else + Maybe.map3 (\aVars bVars cVars -> aVars ++ bVars ++ cVars) + (diffType a x) + (diffType b y) + (Maybe.map List.concat (Utils.zipWithM diffType cs zs)) + + _ -> + Nothing + + + +-- handle very old docs that do not use qualified names + + +isSameName : Name.Name -> Name.Name -> Bool +isSameName oldFullName newFullName = + let + dedot : String -> List String + dedot name = + List.reverse (String.split "." name) + in + case ( dedot oldFullName, dedot newFullName ) of + ( oldName :: [], newName :: _ ) -> + oldName == newName + + ( oldName :: _, newName :: [] ) -> + oldName == newName + + _ -> + oldFullName == newFullName + + +diffFields : List ( Name.Name, Type.Type ) -> List ( Name.Name, Type.Type ) -> Maybe (List ( Name.Name, Name.Name )) +diffFields oldRawFields newRawFields = + if List.length oldRawFields /= List.length newRawFields then + Nothing + + else + let + sort : List ( comparable, b ) -> List ( comparable, b ) + sort fields = + List.sortBy Tuple.first fields + + oldFields : List ( Name.Name, Type.Type ) + oldFields = + sort oldRawFields + + newFields : List ( Name.Name, Type.Type ) + newFields = + sort newRawFields + in + if List.any identity (List.map2 (/=) (List.map Tuple.first oldFields) (List.map Tuple.first newFields)) then + Nothing + + else + Maybe.map List.concat (Utils.zipWithM diffType (List.map Tuple.second oldFields) (List.map Tuple.second newFields)) + + + +-- TYPE VARIABLES + + +isEquivalentRenaming : List ( Name.Name, Name.Name ) -> Bool +isEquivalentRenaming varPairs = + let + renamings : List ( Name.Name, List Name.Name ) + renamings = + Dict.toList compare (List.foldr insert Dict.empty varPairs) + + insert : ( Name.Name, Name.Name ) -> Dict String Name.Name (List Name.Name) -> Dict String Name.Name (List Name.Name) + insert ( old, new ) dict = + Utils.mapInsertWith identity (++) old [ new ] dict + + verify : ( a, List b ) -> Maybe ( a, b ) + verify ( old, news ) = + case news of + [] -> + Nothing + + new :: rest -> + if List.all ((==) new) rest then + Just ( old, new ) + + else + Nothing + + allUnique : List comparable -> Bool + allUnique list = + List.length list == EverySet.size (EverySet.fromList identity list) + in + case Utils.maybeMapM verify renamings of + Nothing -> + False + + Just verifiedRenamings -> + List.all compatibleVars verifiedRenamings + && allUnique (List.map Tuple.second verifiedRenamings) + + +compatibleVars : ( Name.Name, Name.Name ) -> Bool +compatibleVars ( old, new ) = + case ( categorizeVar old, categorizeVar new ) of + ( CompAppend, CompAppend ) -> + True + + ( Comparable, Comparable ) -> + True + + ( Appendable, Appendable ) -> + True + + ( Number, Number ) -> + True + + ( Number, Comparable ) -> + True + + ( _, Var ) -> + True + + _ -> + False + + +type TypeVarCategory + = CompAppend + | Comparable + | Appendable + | Number + | Var + + +categorizeVar : Name.Name -> TypeVarCategory +categorizeVar name = + if Name.isCompappendType name then + CompAppend + + else if Name.isComparableType name then + Comparable + + else if Name.isAppendableType name then + Appendable + + else if Name.isNumberType name then + Number + + else + Var + + + +-- MAGNITUDE + + +bump : PackageChanges -> Version -> Version +bump changes version = + case toMagnitude changes of + M.PATCH -> + V.bumpPatch version + + M.MINOR -> + V.bumpMinor version + + M.MAJOR -> + V.bumpMajor version + + +toMagnitude : PackageChanges -> M.Magnitude +toMagnitude (PackageChanges added changed removed) = + let + addMag : M.Magnitude + addMag = + if List.isEmpty added then + M.PATCH + + else + M.MINOR + + removeMag : M.Magnitude + removeMag = + if List.isEmpty removed then + M.PATCH + + else + M.MAJOR + + changeMags : List M.Magnitude + changeMags = + List.map moduleChangeMagnitude (Dict.values compare changed) + in + Utils.listMaximum M.compare (addMag :: removeMag :: changeMags) + + +moduleChangeMagnitude : ModuleChanges -> M.Magnitude +moduleChangeMagnitude (ModuleChanges unions aliases values binops) = + Utils.listMaximum M.compare + [ changeMagnitude unions + , changeMagnitude aliases + , changeMagnitude values + , changeMagnitude binops + ] + + +changeMagnitude : Changes comparable k v -> M.Magnitude +changeMagnitude (Changes added changed removed) = + if Dict.size removed > 0 || Dict.size changed > 0 then + M.MAJOR + + else if Dict.size added > 0 then + M.MINOR + + else + M.PATCH + + + +-- GET DOCS + + +getDocs : Stuff.PackageCache -> Http.Manager -> Pkg.Name -> V.Version -> Task Never (Result Exit.DocsProblem Docs.Documentation) +getDocs cache manager name version = + let + home : String + home = + Stuff.package cache name version + + path : String + path = + home ++ "/docs.json" + in + File.exists path + |> Task.bind + (\exists -> + if exists then + File.readUtf8 path + |> Task.bind + (\bytes -> + case D.fromByteString Docs.decoder bytes of + Ok docs -> + Task.pure (Ok docs) + + Err _ -> + File.remove path + |> Task.fmap (\_ -> Err DP_Cache) + ) + + else + Website.metadata name version "docs.json" + |> Task.bind + (\url -> + Http.get manager url [] Exit.DP_Http <| + \body -> + case D.fromByteString Docs.decoder body of + Ok docs -> + Utils.dirCreateDirectoryIfMissing True home + |> Task.bind (\_ -> File.writeUtf8 path body) + |> Task.fmap (\_ -> Ok docs) + + Err _ -> + Task.pure (Err (DP_Data url body)) + ) + ) diff --git a/src/Builder/Deps/Registry.elm b/src/Builder/Deps/Registry.elm new file mode 100644 index 0000000000..87e3782fc5 --- /dev/null +++ b/src/Builder/Deps/Registry.elm @@ -0,0 +1,263 @@ +module Builder.Deps.Registry exposing + ( KnownVersions(..) + , Registry(..) + , fetch + , getVersions + , getVersions_ + , latest + , read + , registryDecoder + , registryEncoder + , update + ) + +import Basics.Extra exposing (flip) +import Builder.Deps.Website as Website +import Builder.File as File +import Builder.Http as Http +import Builder.Reporting.Exit as Exit +import Builder.Stuff as Stuff +import Compiler.Elm.Package as Pkg +import Compiler.Elm.Version as V +import Compiler.Json.Decode as D +import Compiler.Parse.Primitives as P +import Data.Map as Dict exposing (Dict) +import Task exposing (Task) +import Utils.Bytes.Decode as BD +import Utils.Bytes.Encode as BE +import Utils.Task.Extra as Task + + + +-- REGISTRY + + +type Registry + = Registry Int (Dict ( String, String ) Pkg.Name KnownVersions) + + +type KnownVersions + = KnownVersions V.Version (List V.Version) + + + +-- READ + + +read : Stuff.PackageCache -> Task Never (Maybe Registry) +read cache = + File.readBinary registryDecoder (Stuff.registry cache) + + + +-- FETCH + + +fetch : Http.Manager -> Stuff.PackageCache -> Task Never (Result Exit.RegistryProblem Registry) +fetch manager cache = + post manager "/all-packages" allPkgsDecoder <| + \versions -> + let + size : Int + size = + Dict.foldr Pkg.compareName (\_ -> addEntry) 0 versions + + registry : Registry + registry = + Registry size versions + + path : String + path = + Stuff.registry cache + in + File.writeBinary registryEncoder path registry + |> Task.fmap (\_ -> registry) + + +addEntry : KnownVersions -> Int -> Int +addEntry (KnownVersions _ vs) count = + count + 1 + List.length vs + + +allPkgsDecoder : D.Decoder () (Dict ( String, String ) Pkg.Name KnownVersions) +allPkgsDecoder = + let + keyDecoder : D.KeyDecoder () Pkg.Name + keyDecoder = + Pkg.keyDecoder bail + + versionsDecoder : D.Decoder () (List V.Version) + versionsDecoder = + D.list (D.mapError (\_ -> ()) V.decoder) + + toKnownVersions : List V.Version -> D.Decoder () KnownVersions + toKnownVersions versions = + case List.sortWith (flip V.compare) versions of + v :: vs -> + D.pure (KnownVersions v vs) + + [] -> + D.failure () + in + D.dict identity keyDecoder (D.bind toKnownVersions versionsDecoder) + + + +-- UPDATE + + +update : Http.Manager -> Stuff.PackageCache -> Registry -> Task Never (Result Exit.RegistryProblem Registry) +update manager cache ((Registry size packages) as oldRegistry) = + post manager ("/all-packages/since/" ++ String.fromInt size) (D.list newPkgDecoder) <| + \news -> + case news of + [] -> + Task.pure oldRegistry + + _ :: _ -> + let + newSize : Int + newSize = + size + List.length news + + newPkgs : Dict ( String, String ) Pkg.Name KnownVersions + newPkgs = + List.foldr addNew packages news + + newRegistry : Registry + newRegistry = + Registry newSize newPkgs + in + File.writeBinary registryEncoder (Stuff.registry cache) newRegistry + |> Task.fmap (\_ -> newRegistry) + + +addNew : ( Pkg.Name, V.Version ) -> Dict ( String, String ) Pkg.Name KnownVersions -> Dict ( String, String ) Pkg.Name KnownVersions +addNew ( name, version ) versions = + let + add : Maybe KnownVersions -> KnownVersions + add maybeKnowns = + case maybeKnowns of + Just (KnownVersions v vs) -> + KnownVersions version (v :: vs) + + Nothing -> + KnownVersions version [] + in + Dict.update identity name (Just << add) versions + + + +-- NEW PACKAGE DECODER + + +newPkgDecoder : D.Decoder () ( Pkg.Name, V.Version ) +newPkgDecoder = + D.customString newPkgParser bail + + +newPkgParser : P.Parser () ( Pkg.Name, V.Version ) +newPkgParser = + P.specialize (\_ _ _ -> ()) Pkg.parser + |> P.bind + (\pkg -> + P.word1 '@' bail + |> P.bind (\_ -> P.specialize (\_ _ _ -> ()) V.parser) + |> P.fmap (\vsn -> ( pkg, vsn )) + ) + + +bail : a -> b -> () +bail _ _ = + () + + + +-- LATEST + + +latest : Http.Manager -> Stuff.PackageCache -> Task Never (Result Exit.RegistryProblem Registry) +latest manager cache = + read cache + |> Task.bind + (\maybeOldRegistry -> + case maybeOldRegistry of + Just oldRegistry -> + update manager cache oldRegistry + + Nothing -> + fetch manager cache + ) + + + +-- GET VERSIONS + + +getVersions : Pkg.Name -> Registry -> Maybe KnownVersions +getVersions name (Registry _ versions) = + Dict.get identity name versions + + +getVersions_ : Pkg.Name -> Registry -> Result (List Pkg.Name) KnownVersions +getVersions_ name (Registry _ versions) = + case Dict.get identity name versions of + Just kvs -> + Ok kvs + + Nothing -> + Err (Pkg.nearbyNames name (Dict.keys compare versions)) + + + +-- POST + + +post : Http.Manager -> String -> D.Decoder x a -> (a -> Task Never b) -> Task Never (Result Exit.RegistryProblem b) +post manager path decoder callback = + Website.route path [] + |> Task.bind + (\url -> + Http.post manager url [] Exit.RP_Http <| + \body -> + case D.fromByteString decoder body of + Ok a -> + Task.fmap Ok (callback a) + + Err _ -> + Task.pure <| Err <| Exit.RP_Data url body + ) + + + +-- ENCODERS and DECODERS + + +registryDecoder : BD.Decoder Registry +registryDecoder = + BD.map2 Registry + BD.int + (BD.assocListDict identity Pkg.nameDecoder knownVersionsDecoder) + + +registryEncoder : Registry -> BE.Encoder +registryEncoder (Registry size versions) = + BE.sequence + [ BE.int size + , BE.assocListDict Pkg.compareName Pkg.nameEncoder knownVersionsEncoder versions + ] + + +knownVersionsDecoder : BD.Decoder KnownVersions +knownVersionsDecoder = + BD.map2 KnownVersions + V.versionDecoder + (BD.list V.versionDecoder) + + +knownVersionsEncoder : KnownVersions -> BE.Encoder +knownVersionsEncoder (KnownVersions version versions) = + BE.sequence + [ V.versionEncoder version + , BE.list V.versionEncoder versions + ] diff --git a/src/Builder/Deps/Solver.elm b/src/Builder/Deps/Solver.elm new file mode 100644 index 0000000000..e357010ef9 --- /dev/null +++ b/src/Builder/Deps/Solver.elm @@ -0,0 +1,763 @@ +module Builder.Deps.Solver exposing + ( AppSolution(..) + , Connection(..) + , Details(..) + , Env(..) + , Solver + , SolverResult(..) + , State + , addToApp + , addToTestApp + , envDecoder + , envEncoder + , initEnv + , removeFromApp + , verify + ) + +import Builder.Deps.Registry as Registry +import Builder.Deps.Website as Website +import Builder.Elm.Outline as Outline +import Builder.File as File +import Builder.Http as Http +import Builder.Reporting.Exit as Exit +import Builder.Stuff as Stuff +import Compiler.Elm.Constraint as C +import Compiler.Elm.Package as Pkg +import Compiler.Elm.Version as V +import Compiler.Json.Decode as D +import Data.Map as Dict exposing (Dict) +import Task exposing (Task) +import Utils.Bytes.Decode as BD +import Utils.Bytes.Encode as BE +import Utils.Crash exposing (crash) +import Utils.Main as Utils +import Utils.Task.Extra as Task + + + +-- SOLVER + + +type Solver a + = Solver (State -> Task Never (InnerSolver a)) + + +type InnerSolver a + = ISOk State a + | ISBack State + | ISErr Exit.Solver + + +type State + = State Stuff.PackageCache Connection Registry.Registry (Dict ( ( String, String ), ( Int, Int, Int ) ) ( Pkg.Name, V.Version ) Constraints) + + +type Constraints + = Constraints C.Constraint (Dict ( String, String ) Pkg.Name C.Constraint) + + +type Connection + = Online Http.Manager + | Offline + + + +-- RESULT + + +type SolverResult a + = SolverOk a + | NoSolution + | NoOfflineSolution + | SolverErr Exit.Solver + + + +-- VERIFY -- used by Elm.Details + + +type Details + = Details V.Version (Dict ( String, String ) Pkg.Name C.Constraint) + + +verify : Stuff.PackageCache -> Connection -> Registry.Registry -> Dict ( String, String ) Pkg.Name C.Constraint -> Task Never (SolverResult (Dict ( String, String ) Pkg.Name Details)) +verify cache connection registry constraints = + Stuff.withRegistryLock cache <| + case try constraints of + Solver solver -> + solver (State cache connection registry Dict.empty) + |> Task.fmap + (\result -> + case result of + ISOk s a -> + SolverOk (Dict.map (addDeps s) a) + + ISBack _ -> + noSolution connection + + ISErr e -> + SolverErr e + ) + + +addDeps : State -> Pkg.Name -> V.Version -> Details +addDeps (State _ _ _ constraints) name vsn = + case Dict.get (Tuple.mapSecond V.toComparable) ( name, vsn ) constraints of + Just (Constraints _ deps) -> + Details vsn deps + + Nothing -> + crash "compiler bug manifesting in Deps.Solver.addDeps" + + +noSolution : Connection -> SolverResult a +noSolution connection = + case connection of + Online _ -> + NoSolution + + Offline -> + NoOfflineSolution + + + +-- APP SOLUTION + + +type AppSolution + = AppSolution (Dict ( String, String ) Pkg.Name V.Version) (Dict ( String, String ) Pkg.Name V.Version) Outline.AppOutline + + +getTransitive : Dict ( ( String, String ), ( Int, Int, Int ) ) ( Pkg.Name, V.Version ) Constraints -> Dict ( String, String ) Pkg.Name V.Version -> List ( Pkg.Name, V.Version ) -> Dict ( String, String ) Pkg.Name V.Version -> Dict ( String, String ) Pkg.Name V.Version +getTransitive constraints solution unvisited visited = + case unvisited of + [] -> + visited + + (( pkg, vsn ) as info) :: infos -> + if Dict.member identity pkg visited then + getTransitive constraints solution infos visited + + else + let + (Constraints _ newDeps) = + Utils.find (Tuple.mapSecond V.toComparable) info constraints + + newUnvisited : List ( Pkg.Name, V.Version ) + newUnvisited = + Dict.toList compare (Dict.intersection Pkg.compareName solution (Dict.diff newDeps visited)) + + newVisited : Dict ( String, String ) Pkg.Name V.Version + newVisited = + Dict.insert identity pkg vsn visited + in + getTransitive constraints solution infos <| + getTransitive constraints solution newUnvisited newVisited + + + +-- ADD TO APP - used in Install + + +addToApp : Stuff.PackageCache -> Connection -> Registry.Registry -> Pkg.Name -> Outline.AppOutline -> Bool -> Task Never (SolverResult AppSolution) +addToApp cache connection registry pkg (Outline.AppOutline elm srcDirs direct indirect testDirect testIndirect) forTest = + Stuff.withRegistryLock cache <| + let + allIndirects : Dict ( String, String ) Pkg.Name V.Version + allIndirects = + Dict.union indirect testIndirect + + allDirects : Dict ( String, String ) Pkg.Name V.Version + allDirects = + Dict.union direct testDirect + + allDeps : Dict ( String, String ) Pkg.Name V.Version + allDeps = + Dict.union allDirects allIndirects + + attempt : (a -> C.Constraint) -> Dict ( String, String ) Pkg.Name a -> Solver (Dict ( String, String ) Pkg.Name V.Version) + attempt toConstraint deps = + try (Dict.insert identity pkg C.anything (Dict.map (\_ -> toConstraint) deps)) + in + case + oneOf + (attempt C.exactly allDeps) + [ attempt C.exactly allDirects + , attempt C.untilNextMinor allDirects + , attempt C.untilNextMajor allDirects + , attempt (\_ -> C.anything) allDirects + ] + of + Solver solver -> + solver (State cache connection registry Dict.empty) + |> Task.fmap + (\result -> + case result of + ISOk (State _ _ _ constraints) new -> + let + d : Dict ( String, String ) Pkg.Name V.Version + d = + if forTest then + Dict.intersection Pkg.compareName new direct + + else + Dict.intersection Pkg.compareName new (Dict.insert identity pkg V.one direct) + + i : Dict ( String, String ) Pkg.Name V.Version + i = + Dict.diff (getTransitive constraints new (Dict.toList compare d) Dict.empty) d + + td : Dict ( String, String ) Pkg.Name V.Version + td = + if forTest then + Dict.intersection Pkg.compareName new (Dict.insert identity pkg V.one testDirect) + + else + Dict.intersection Pkg.compareName new (Dict.remove identity pkg testDirect) + + ti : Dict ( String, String ) Pkg.Name V.Version + ti = + Dict.diff new (Utils.mapUnions [ d, i, td ]) + in + SolverOk (AppSolution allDeps new (Outline.AppOutline elm srcDirs d i td ti)) + + ISBack _ -> + noSolution connection + + ISErr e -> + SolverErr e + ) + + + +-- ADD TO APP - used in Test + + +addToTestApp : Stuff.PackageCache -> Connection -> Registry.Registry -> Pkg.Name -> C.Constraint -> Outline.AppOutline -> Task Never (SolverResult AppSolution) +addToTestApp cache connection registry pkg con (Outline.AppOutline elm srcDirs direct indirect testDirect testIndirect) = + Stuff.withRegistryLock cache <| + let + allIndirects : Dict ( String, String ) Pkg.Name V.Version + allIndirects = + Dict.union indirect testIndirect + + allDirects : Dict ( String, String ) Pkg.Name V.Version + allDirects = + Dict.union direct testDirect + + allDeps : Dict ( String, String ) Pkg.Name V.Version + allDeps = + Dict.union allDirects allIndirects + + attempt : (a -> C.Constraint) -> Dict ( String, String ) Pkg.Name a -> Solver (Dict ( String, String ) Pkg.Name V.Version) + attempt toConstraint deps = + try (Dict.insert identity pkg con (Dict.map (\_ -> toConstraint) deps)) + in + case + oneOf + (attempt C.exactly allDeps) + [ attempt C.exactly allDirects + , attempt C.untilNextMinor allDirects + , attempt C.untilNextMajor allDirects + , attempt (\_ -> C.anything) allDirects + ] + of + Solver solver -> + solver (State cache connection registry Dict.empty) + |> Task.fmap + (\result -> + case result of + ISOk (State _ _ _ constraints) new -> + let + d : Dict ( String, String ) Pkg.Name V.Version + d = + Dict.intersection Pkg.compareName new (Dict.insert identity pkg V.one direct) + + i : Dict ( String, String ) Pkg.Name V.Version + i = + Dict.diff (getTransitive constraints new (Dict.toList compare d) Dict.empty) d + + td : Dict ( String, String ) Pkg.Name V.Version + td = + Dict.intersection Pkg.compareName new (Dict.remove identity pkg testDirect) + + ti : Dict ( String, String ) Pkg.Name V.Version + ti = + Dict.diff new (Utils.mapUnions [ d, i, td ]) + in + SolverOk (AppSolution allDeps new (Outline.AppOutline elm srcDirs d i td ti)) + + ISBack _ -> + noSolution connection + + ISErr e -> + SolverErr e + ) + + + +-- REMOVE FROM APP - used in Uninstall + + +removeFromApp : Stuff.PackageCache -> Connection -> Registry.Registry -> Pkg.Name -> Outline.AppOutline -> Task Never (SolverResult AppSolution) +removeFromApp cache connection registry pkg (Outline.AppOutline elm srcDirs direct indirect testDirect testIndirect) = + Stuff.withRegistryLock cache <| + let + allDirects : Dict ( String, String ) Pkg.Name V.Version + allDirects = + Dict.union direct testDirect + in + case try (Dict.map (\_ -> C.exactly) (Dict.remove identity pkg allDirects)) of + Solver solver -> + solver (State cache connection registry Dict.empty) + |> Task.fmap + (\result -> + case result of + ISOk (State _ _ _ constraints) new -> + let + allIndirects : Dict ( String, String ) Pkg.Name V.Version + allIndirects = + Dict.union indirect testIndirect + + allDeps : Dict ( String, String ) Pkg.Name V.Version + allDeps = + Dict.union allDirects allIndirects + + d : Dict ( String, String ) Pkg.Name V.Version + d = + Dict.remove identity pkg direct + + i : Dict ( String, String ) Pkg.Name V.Version + i = + Dict.diff (getTransitive constraints new (Dict.toList compare d) Dict.empty) d + + td : Dict ( String, String ) Pkg.Name V.Version + td = + Dict.remove identity pkg testDirect + + ti : Dict ( String, String ) Pkg.Name V.Version + ti = + Dict.diff new (Utils.mapUnions [ d, i, td ]) + in + SolverOk (AppSolution allDeps new (Outline.AppOutline elm srcDirs d i td ti)) + + ISBack _ -> + noSolution connection + + ISErr e -> + SolverErr e + ) + + + +-- TRY + + +try : Dict ( String, String ) Pkg.Name C.Constraint -> Solver (Dict ( String, String ) Pkg.Name V.Version) +try constraints = + exploreGoals (Goals constraints Dict.empty) + + + +-- EXPLORE GOALS + + +type Goals + = Goals (Dict ( String, String ) Pkg.Name C.Constraint) (Dict ( String, String ) Pkg.Name V.Version) + + +exploreGoals : Goals -> Solver (Dict ( String, String ) Pkg.Name V.Version) +exploreGoals (Goals pending solved) = + let + compare : ( Pkg.Name, C.Constraint ) -> Pkg.Name + compare = + Tuple.first + in + case Utils.mapMinViewWithKey identity Basics.compare compare pending of + Nothing -> + pure solved + + Just ( ( name, constraint ), otherPending ) -> + let + goals1 : Goals + goals1 = + Goals otherPending solved + + addVsn : V.Version -> Solver Goals + addVsn = + addVersion goals1 name + in + getRelevantVersions name constraint + |> bind (\( v, vs ) -> oneOf (addVsn v) (List.map addVsn vs)) + |> bind (\goals2 -> exploreGoals goals2) + + +addVersion : Goals -> Pkg.Name -> V.Version -> Solver Goals +addVersion (Goals pending solved) name version = + getConstraints name version + |> bind + (\(Constraints elm deps) -> + if C.goodElm elm then + foldM (addConstraint solved) pending (Dict.toList compare deps) + |> fmap + (\newPending -> + Goals newPending (Dict.insert identity name version solved) + ) + + else + backtrack + ) + + +addConstraint : Dict ( String, String ) Pkg.Name V.Version -> Dict ( String, String ) Pkg.Name C.Constraint -> ( Pkg.Name, C.Constraint ) -> Solver (Dict ( String, String ) Pkg.Name C.Constraint) +addConstraint solved unsolved ( name, newConstraint ) = + case Dict.get identity name solved of + Just version -> + if C.satisfies newConstraint version then + pure unsolved + + else + backtrack + + Nothing -> + case Dict.get identity name unsolved of + Nothing -> + pure (Dict.insert identity name newConstraint unsolved) + + Just oldConstraint -> + case C.intersect oldConstraint newConstraint of + Nothing -> + backtrack + + Just mergedConstraint -> + if oldConstraint == mergedConstraint then + pure unsolved + + else + pure (Dict.insert identity name mergedConstraint unsolved) + + + +-- GET RELEVANT VERSIONS + + +getRelevantVersions : Pkg.Name -> C.Constraint -> Solver ( V.Version, List V.Version ) +getRelevantVersions name constraint = + Solver <| + \((State _ _ registry _) as state) -> + case Registry.getVersions name registry of + Just (Registry.KnownVersions newest previous) -> + case List.filter (C.satisfies constraint) (newest :: previous) of + [] -> + Task.pure (ISBack state) + + v :: vs -> + Task.pure (ISOk state ( v, vs )) + + Nothing -> + Task.pure (ISBack state) + + + +-- GET CONSTRAINTS + + +getConstraints : Pkg.Name -> V.Version -> Solver Constraints +getConstraints pkg vsn = + Solver <| + \((State cache connection registry cDict) as state) -> + let + key : ( Pkg.Name, V.Version ) + key = + ( pkg, vsn ) + in + case Dict.get (Tuple.mapSecond V.toComparable) key cDict of + Just cs -> + Task.pure (ISOk state cs) + + Nothing -> + let + toNewState : Constraints -> State + toNewState cs = + State cache connection registry (Dict.insert (Tuple.mapSecond V.toComparable) key cs cDict) + + home : String + home = + Stuff.package cache pkg vsn + + path : String + path = + home ++ "/elm.json" + in + File.exists path + |> Task.bind + (\outlineExists -> + if outlineExists then + File.readUtf8 path + |> Task.bind + (\bytes -> + case D.fromByteString constraintsDecoder bytes of + Ok cs -> + case connection of + Online _ -> + Task.pure (ISOk (toNewState cs) cs) + + Offline -> + Utils.dirDoesDirectoryExist (Stuff.package cache pkg vsn ++ "/src") + |> Task.fmap + (\srcExists -> + if srcExists then + ISOk (toNewState cs) cs + + else + ISBack state + ) + + Err _ -> + File.remove path + |> Task.fmap (\_ -> ISErr (Exit.SolverBadCacheData pkg vsn)) + ) + + else + case connection of + Offline -> + Task.pure (ISBack state) + + Online manager -> + Website.metadata pkg vsn "elm.json" + |> Task.bind + (\url -> + Http.get manager url [] identity (Task.pure << Ok) + |> Task.bind + (\result -> + case result of + Err httpProblem -> + Task.pure (ISErr (Exit.SolverBadHttp pkg vsn httpProblem)) + + Ok body -> + case D.fromByteString constraintsDecoder body of + Ok cs -> + Utils.dirCreateDirectoryIfMissing True home + |> Task.bind (\_ -> File.writeUtf8 path body) + |> Task.fmap (\_ -> ISOk (toNewState cs) cs) + + Err _ -> + Task.pure (ISErr (Exit.SolverBadHttpData pkg vsn url)) + ) + ) + ) + + +constraintsDecoder : D.Decoder () Constraints +constraintsDecoder = + D.mapError (\_ -> ()) Outline.decoder + |> D.bind + (\outline -> + case outline of + Outline.Pkg (Outline.PkgOutline _ _ _ _ _ deps _ elmConstraint) -> + D.pure (Constraints elmConstraint deps) + + Outline.App _ -> + D.failure () + ) + + + +-- ENVIRONMENT + + +type Env + = Env Stuff.PackageCache Http.Manager Connection Registry.Registry + + +initEnv : Task Never (Result Exit.RegistryProblem Env) +initEnv = + Utils.newEmptyMVar + |> Task.bind + (\mvar -> + Utils.forkIO (Task.bind (Utils.putMVar Http.managerEncoder mvar) Http.getManager) + |> Task.bind + (\_ -> + Stuff.getPackageCache + |> Task.bind + (\cache -> + Stuff.withRegistryLock cache + (Registry.read cache + |> Task.bind + (\maybeRegistry -> + Utils.readMVar Http.managerDecoder mvar + |> Task.bind + (\manager -> + case maybeRegistry of + Nothing -> + Registry.fetch manager cache + |> Task.fmap + (\eitherRegistry -> + case eitherRegistry of + Ok latestRegistry -> + Ok <| Env cache manager (Online manager) latestRegistry + + Err problem -> + Err problem + ) + + Just cachedRegistry -> + Registry.update manager cache cachedRegistry + |> Task.fmap + (\eitherRegistry -> + case eitherRegistry of + Ok latestRegistry -> + Ok <| Env cache manager (Online manager) latestRegistry + + Err _ -> + Ok <| Env cache manager Offline cachedRegistry + ) + ) + ) + ) + ) + ) + ) + + + +-- INSTANCES + + +fmap : (a -> b) -> Solver a -> Solver b +fmap func (Solver solver) = + Solver <| + \state -> + solver state + |> Task.fmap + (\result -> + case result of + ISOk stateA arg -> + ISOk stateA (func arg) + + ISBack stateA -> + ISBack stateA + + ISErr e -> + ISErr e + ) + + +pure : a -> Solver a +pure a = + Solver (\state -> Task.pure (ISOk state a)) + + +bind : (a -> Solver b) -> Solver a -> Solver b +bind callback (Solver solverA) = + Solver <| + \state -> + solverA state + |> Task.bind + (\resA -> + case resA of + ISOk stateA a -> + case callback a of + Solver solverB -> + solverB stateA + + ISBack stateA -> + Task.pure (ISBack stateA) + + ISErr e -> + Task.pure (ISErr e) + ) + + +oneOf : Solver a -> List (Solver a) -> Solver a +oneOf ((Solver solverHead) as solver) solvers = + case solvers of + [] -> + solver + + s :: ss -> + Solver <| + \state0 -> + solverHead state0 + |> Task.bind + (\result -> + case result of + ISOk stateA arg -> + Task.pure (ISOk stateA arg) + + ISBack stateA -> + let + (Solver solverTail) = + oneOf s ss + in + solverTail stateA + + ISErr e -> + Task.pure (ISErr e) + ) + + +backtrack : Solver a +backtrack = + Solver <| + \state -> + Task.pure (ISBack state) + + +foldM : (b -> a -> Solver b) -> b -> List a -> Solver b +foldM f b = + List.foldl (\a -> bind (\acc -> f acc a)) (pure b) + + + +-- ENCODERS and DECODERS + + +envEncoder : Env -> BE.Encoder +envEncoder (Env cache manager connection registry) = + BE.sequence + [ Stuff.packageCacheEncoder cache + , Http.managerEncoder manager + , connectionEncoder connection + , Registry.registryEncoder registry + ] + + +envDecoder : BD.Decoder Env +envDecoder = + BD.map4 Env + Stuff.packageCacheDecoder + Http.managerDecoder + connectionDecoder + Registry.registryDecoder + + +connectionEncoder : Connection -> BE.Encoder +connectionEncoder connection = + case connection of + Online manager -> + BE.sequence + [ BE.unsignedInt8 0 + , Http.managerEncoder manager + ] + + Offline -> + BE.unsignedInt8 1 + + +connectionDecoder : BD.Decoder Connection +connectionDecoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.map Online Http.managerDecoder + + 1 -> + BD.succeed Offline + + _ -> + BD.fail + ) diff --git a/src/Builder/Deps/Website.elm b/src/Builder/Deps/Website.elm new file mode 100644 index 0000000000..7d2a652694 --- /dev/null +++ b/src/Builder/Deps/Website.elm @@ -0,0 +1,29 @@ +module Builder.Deps.Website exposing + ( metadata + , route + ) + +import Builder.Http as Http +import Compiler.Elm.Package as Pkg +import Compiler.Elm.Version as V +import Task exposing (Task) +import Utils.Main as Utils +import Utils.Task.Extra as Task + + +domain : Task Never String +domain = + Utils.envLookupEnv "GUIDA_REGISTRY" + |> Task.fmap (Maybe.withDefault "https://package.elm-lang.org") + + +route : String -> List ( String, String ) -> Task Never String +route path params = + domain + |> Task.fmap (\d -> Http.toUrl (d ++ path) params) + + +metadata : Pkg.Name -> V.Version -> String -> Task Never String +metadata name version file = + domain + |> Task.fmap (\d -> d ++ "/packages/" ++ Pkg.toUrl name ++ "/" ++ V.toChars version ++ "/" ++ file) diff --git a/src/Builder/Elm/Details.elm b/src/Builder/Elm/Details.elm new file mode 100644 index 0000000000..d0bc178b55 --- /dev/null +++ b/src/Builder/Elm/Details.elm @@ -0,0 +1,1469 @@ +module Builder.Elm.Details exposing + ( BuildID + , Details(..) + , Extras + , Foreign(..) + , Interfaces + , Local(..) + , Status + , ValidOutline(..) + , detailsEncoder + , load + , loadInterfaces + , loadObjects + , localDecoder + , localEncoder + , verifyInstall + ) + +import Builder.BackgroundWriter as BW +import Builder.Deps.Registry as Registry +import Builder.Deps.Solver as Solver +import Builder.Deps.Website as Website +import Builder.Elm.Outline as Outline +import Builder.File as File +import Builder.Http as Http +import Builder.Reporting as Reporting +import Builder.Reporting.Exit as Exit +import Builder.Stuff as Stuff +import Compiler.AST.Canonical as Can +import Compiler.AST.Optimized as Opt +import Compiler.AST.Source as Src +import Compiler.Compile as Compile +import Compiler.Data.Name as Name +import Compiler.Data.NonEmptyList as NE +import Compiler.Data.OneOrMore as OneOrMore +import Compiler.Elm.Constraint as Con +import Compiler.Elm.Docs as Docs +import Compiler.Elm.Interface as I +import Compiler.Elm.Kernel as Kernel +import Compiler.Elm.ModuleName as ModuleName +import Compiler.Elm.Package as Pkg +import Compiler.Elm.Version as V +import Compiler.Json.Decode as D +import Compiler.Json.Encode as E +import Compiler.Parse.Module as Parse +import Compiler.Parse.SyntaxVersion as SV exposing (SyntaxVersion) +import Compiler.Reporting.Annotation as A +import Data.Map as Dict exposing (Dict) +import Data.Set as EverySet exposing (EverySet) +import System.TypeCheck.IO as TypeCheck +import Task exposing (Task) +import Utils.Bytes.Decode as BD +import Utils.Bytes.Encode as BE +import Utils.Crash exposing (crash) +import Utils.Main as Utils exposing (FilePath, MVar) +import Utils.Task.Extra as Task + + + +-- DETAILS + + +type Details + = Details File.Time ValidOutline BuildID (Dict String ModuleName.Raw Local) (Dict String ModuleName.Raw Foreign) Extras + + +type alias BuildID = + Int + + +type ValidOutline + = ValidApp (NE.Nonempty Outline.SrcDir) + | ValidPkg Pkg.Name (List ModuleName.Raw) (Dict ( String, String ) Pkg.Name V.Version {- for docs in reactor -}) + + + +-- NOTE: we need two ways to detect if a file must be recompiled: +-- +-- (1) _time is the modification time from the last time we compiled the file. +-- By checking EQUALITY with the current modification time, we can detect file +-- saves and `git checkout` of previous versions. Both need a recompile. +-- +-- (2) _lastChange is the BuildID from the last time a new interface file was +-- generated, and _lastCompile is the BuildID from the last time the file was +-- compiled. These may be different if a file is recompiled but the interface +-- stayed the same. When the _lastCompile is LESS THAN the _lastChange of any +-- imports, we need to recompile. This can happen when a project has multiple +-- entrypoints and some modules are compiled less often than their imports. +-- + + +type Local + = Local FilePath File.Time (List ModuleName.Raw) Bool BuildID BuildID + + +type Foreign + = Foreign Pkg.Name (List Pkg.Name) + + +type Extras + = ArtifactsCached + | ArtifactsFresh Interfaces Opt.GlobalGraph + + +type alias Interfaces = + Dict (List String) TypeCheck.Canonical I.DependencyInterface + + + +-- LOAD ARTIFACTS + + +loadObjects : FilePath -> Details -> Task Never (MVar (Maybe Opt.GlobalGraph)) +loadObjects root (Details _ _ _ _ _ extras) = + case extras of + ArtifactsFresh _ o -> + Utils.newMVar (Utils.maybeEncoder Opt.globalGraphEncoder) (Just o) + + ArtifactsCached -> + fork (Utils.maybeEncoder Opt.globalGraphEncoder) (File.readBinary Opt.globalGraphDecoder (Stuff.objects root)) + + +loadInterfaces : FilePath -> Details -> Task Never (MVar (Maybe Interfaces)) +loadInterfaces root (Details _ _ _ _ _ extras) = + case extras of + ArtifactsFresh i _ -> + Utils.newMVar (Utils.maybeEncoder interfacesEncoder) (Just i) + + ArtifactsCached -> + fork (Utils.maybeEncoder interfacesEncoder) (File.readBinary interfacesDecoder (Stuff.interfaces root)) + + + +-- VERIFY INSTALL -- used by Install + + +verifyInstall : BW.Scope -> FilePath -> Solver.Env -> Outline.Outline -> Task Never (Result Exit.Details ()) +verifyInstall scope root (Solver.Env cache manager connection registry) outline = + File.getTime (root ++ "/elm.json") + |> Task.bind + (\time -> + let + key : Reporting.Key msg + key = + Reporting.ignorer + + env : Env + env = + Env key scope root cache manager connection registry + in + case outline of + Outline.Pkg pkg -> + Task.run (Task.fmap (\_ -> ()) (verifyPkg env time pkg)) + + Outline.App app -> + Task.run (Task.fmap (\_ -> ()) (verifyApp env time app)) + ) + + + +-- LOAD -- used by Make, Repl, Reactor, Test + + +load : Reporting.Style -> BW.Scope -> FilePath -> Task Never (Result Exit.Details Details) +load style scope root = + File.getTime (root ++ "/elm.json") + |> Task.bind + (\newTime -> + File.readBinary detailsDecoder (Stuff.details root) + |> Task.bind + (\maybeDetails -> + case maybeDetails of + Nothing -> + generate style scope root newTime + + Just (Details oldTime outline buildID locals foreigns extras) -> + if oldTime == newTime then + Task.pure (Ok (Details oldTime outline (buildID + 1) locals foreigns extras)) + + else + generate style scope root newTime + ) + ) + + + +-- GENERATE + + +generate : Reporting.Style -> BW.Scope -> FilePath -> File.Time -> Task Never (Result Exit.Details Details) +generate style scope root time = + Reporting.trackDetails style + (\key -> + initEnv key scope root + |> Task.bind + (\result -> + case result of + Err exit -> + Task.pure (Err exit) + + Ok ( env, outline ) -> + case outline of + Outline.Pkg pkg -> + Task.run (verifyPkg env time pkg) + + Outline.App app -> + Task.run (verifyApp env time app) + ) + ) + + + +-- ENV + + +type Env + = Env Reporting.DKey BW.Scope FilePath Stuff.PackageCache Http.Manager Solver.Connection Registry.Registry + + +initEnv : Reporting.DKey -> BW.Scope -> FilePath -> Task Never (Result Exit.Details ( Env, Outline.Outline )) +initEnv key scope root = + fork resultRegistryProblemEnvEncoder Solver.initEnv + |> Task.bind + (\mvar -> + Outline.read root + |> Task.bind + (\eitherOutline -> + case eitherOutline of + Err problem -> + Task.pure (Err (Exit.DetailsBadOutline problem)) + + Ok outline -> + Utils.readMVar resultRegistryProblemEnvDecoder mvar + |> Task.fmap + (\maybeEnv -> + case maybeEnv of + Err problem -> + Err (Exit.DetailsCannotGetRegistry problem) + + Ok (Solver.Env cache manager connection registry) -> + Ok ( Env key scope root cache manager connection registry, outline ) + ) + ) + ) + + + +-- VERIFY PROJECT + + +verifyPkg : Env -> File.Time -> Outline.PkgOutline -> Task Exit.Details Details +verifyPkg env time (Outline.PkgOutline pkg _ _ _ exposed direct testDirect elm) = + if Con.goodElm elm then + union identity Pkg.compareName noDups direct testDirect + |> Task.bind (verifyConstraints env) + |> Task.bind + (\solution -> + let + exposedList : List ModuleName.Raw + exposedList = + Outline.flattenExposed exposed + + exactDeps : Dict ( String, String ) Pkg.Name V.Version + exactDeps = + Dict.map (\_ (Solver.Details v _) -> v) solution + + -- for pkg docs in reactor + in + verifyDependencies env time (ValidPkg pkg exposedList exactDeps) solution direct + ) + + else + Task.throw (Exit.DetailsBadElmInPkg elm) + + +verifyApp : Env -> File.Time -> Outline.AppOutline -> Task Exit.Details Details +verifyApp env time ((Outline.AppOutline elmVersion srcDirs direct _ _ _) as outline) = + if elmVersion == V.elmCompiler then + checkAppDeps outline + |> Task.bind + (\stated -> + verifyConstraints env (Dict.map (\_ -> Con.exactly) stated) + |> Task.bind + (\actual -> + if Dict.size stated == Dict.size actual then + verifyDependencies env time (ValidApp srcDirs) actual direct + + else + Task.throw Exit.DetailsHandEditedDependencies + ) + ) + + else + Task.throw (Exit.DetailsBadElmInAppOutline elmVersion) + + +checkAppDeps : Outline.AppOutline -> Task Exit.Details (Dict ( String, String ) Pkg.Name V.Version) +checkAppDeps (Outline.AppOutline _ _ direct indirect testDirect testIndirect) = + union identity Pkg.compareName allowEqualDups indirect testDirect + |> Task.bind + (\x -> + union identity Pkg.compareName noDups direct testIndirect + |> Task.bind (\y -> union identity Pkg.compareName noDups x y) + ) + + + +-- VERIFY CONSTRAINTS + + +verifyConstraints : Env -> Dict ( String, String ) Pkg.Name Con.Constraint -> Task Exit.Details (Dict ( String, String ) Pkg.Name Solver.Details) +verifyConstraints (Env _ _ _ cache _ connection registry) constraints = + Task.io (Solver.verify cache connection registry constraints) + |> Task.bind + (\result -> + case result of + Solver.SolverOk details -> + Task.pure details + + Solver.NoSolution -> + Task.throw Exit.DetailsNoSolution + + Solver.NoOfflineSolution -> + Task.throw Exit.DetailsNoOfflineSolution + + Solver.SolverErr exit -> + Task.throw (Exit.DetailsSolverProblem exit) + ) + + + +-- UNION + + +union : (k -> comparable) -> (k -> k -> Order) -> (k -> v -> v -> Task Exit.Details v) -> Dict comparable k v -> Dict comparable k v -> Task Exit.Details (Dict comparable k v) +union toComparable keyComparison tieBreaker deps1 deps2 = + Dict.merge keyComparison + (\k dep -> Task.fmap (Dict.insert toComparable k dep)) + (\k dep1 dep2 acc -> + tieBreaker k dep1 dep2 + |> Task.bind (\v -> Task.fmap (Dict.insert toComparable k v) acc) + ) + (\k dep -> Task.fmap (Dict.insert toComparable k dep)) + deps1 + deps2 + (Task.pure Dict.empty) + + +noDups : k -> v -> v -> Task Exit.Details v +noDups _ _ _ = + Task.throw Exit.DetailsHandEditedDependencies + + +allowEqualDups : k -> v -> v -> Task Exit.Details v +allowEqualDups _ v1 v2 = + if v1 == v2 then + Task.pure v1 + + else + Task.throw Exit.DetailsHandEditedDependencies + + + +-- FORK + + +fork : (a -> BE.Encoder) -> Task Never a -> Task Never (MVar a) +fork encoder work = + Utils.newEmptyMVar + |> Task.bind + (\mvar -> + Utils.forkIO (Task.bind (Utils.putMVar encoder mvar) work) + |> Task.fmap (\_ -> mvar) + ) + + + +-- VERIFY DEPENDENCIES + + +verifyDependencies : Env -> File.Time -> ValidOutline -> Dict ( String, String ) Pkg.Name Solver.Details -> Dict ( String, String ) Pkg.Name a -> Task Exit.Details Details +verifyDependencies ((Env key scope root cache _ _ _) as env) time outline solution directDeps = + Task.eio identity + (Reporting.report key (Reporting.DStart (Dict.size solution)) + |> Task.bind (\_ -> Utils.newEmptyMVar) + |> Task.bind + (\mvar -> + Stuff.withRegistryLock cache + (Utils.mapTraverseWithKey identity Pkg.compareName (\k v -> fork depEncoder (verifyDep env mvar solution k v)) solution) + |> Task.bind + (\mvars -> + Utils.putMVar dictNameMVarDepEncoder mvar mvars + |> Task.bind + (\_ -> + Utils.mapTraverse identity Pkg.compareName (Utils.readMVar depDecoder) mvars + |> Task.bind + (\deps -> + case Utils.sequenceDictResult identity Pkg.compareName deps of + Err _ -> + Stuff.getElmHome + |> Task.fmap + (\home -> + Err + (Exit.DetailsBadDeps home + (List.filterMap identity (Utils.eitherLefts (Dict.values compare deps))) + ) + ) + + Ok artifacts -> + let + objs : Opt.GlobalGraph + objs = + Dict.foldr compare (\_ -> addObjects) Opt.empty artifacts + + ifaces : Interfaces + ifaces = + Dict.foldr compare (addInterfaces directDeps) Dict.empty artifacts + + foreigns : Dict String ModuleName.Raw Foreign + foreigns = + Dict.map (\_ -> OneOrMore.destruct Foreign) (Dict.foldr compare gatherForeigns Dict.empty (Dict.intersection compare artifacts directDeps)) + + details : Details + details = + Details time outline 0 Dict.empty foreigns (ArtifactsFresh ifaces objs) + in + BW.writeBinary Opt.globalGraphEncoder scope (Stuff.objects root) objs + |> Task.bind (\_ -> BW.writeBinary interfacesEncoder scope (Stuff.interfaces root) ifaces) + |> Task.bind (\_ -> BW.writeBinary detailsEncoder scope (Stuff.details root) details) + |> Task.fmap (\_ -> Ok details) + ) + ) + ) + ) + ) + + +addObjects : Artifacts -> Opt.GlobalGraph -> Opt.GlobalGraph +addObjects (Artifacts _ objs) graph = + Opt.addGlobalGraph objs graph + + +addInterfaces : Dict ( String, String ) Pkg.Name a -> Pkg.Name -> Artifacts -> Interfaces -> Interfaces +addInterfaces directDeps pkg (Artifacts ifaces _) dependencyInterfaces = + Dict.union + dependencyInterfaces + (Dict.fromList ModuleName.toComparableCanonical + (List.map (Tuple.mapFirst (TypeCheck.Canonical pkg)) + (Dict.toList compare + (if Dict.member identity pkg directDeps then + ifaces + + else + Dict.map (\_ -> I.privatize) ifaces + ) + ) + ) + ) + + +gatherForeigns : Pkg.Name -> Artifacts -> Dict String ModuleName.Raw (OneOrMore.OneOrMore Pkg.Name) -> Dict String ModuleName.Raw (OneOrMore.OneOrMore Pkg.Name) +gatherForeigns pkg (Artifacts ifaces _) foreigns = + let + isPublic : I.DependencyInterface -> Maybe (OneOrMore.OneOrMore Pkg.Name) + isPublic di = + case di of + I.Public _ -> + Just (OneOrMore.one pkg) + + I.Private _ _ _ -> + Nothing + in + Utils.mapUnionWith identity compare OneOrMore.more foreigns (Utils.mapMapMaybe identity compare isPublic ifaces) + + + +-- VERIFY DEPENDENCY + + +type Artifacts + = Artifacts (Dict String ModuleName.Raw I.DependencyInterface) Opt.GlobalGraph + + +type alias Dep = + Result (Maybe Exit.DetailsBadDep) Artifacts + + +verifyDep : Env -> MVar (Dict ( String, String ) Pkg.Name (MVar Dep)) -> Dict ( String, String ) Pkg.Name Solver.Details -> Pkg.Name -> Solver.Details -> Task Never Dep +verifyDep (Env key _ _ cache manager _ _) depsMVar solution pkg ((Solver.Details vsn directDeps) as details) = + let + fingerprint : Dict ( String, String ) Pkg.Name V.Version + fingerprint = + Utils.mapIntersectionWith identity Pkg.compareName (\(Solver.Details v _) _ -> v) solution directDeps + in + Utils.dirDoesDirectoryExist (Stuff.package cache pkg vsn ++ "/src") + |> Task.bind + (\exists -> + if exists then + Reporting.report key Reporting.DCached + |> Task.bind + (\_ -> + File.readBinary artifactCacheDecoder (Stuff.package cache pkg vsn ++ "/artifacts.dat") + |> Task.bind + (\maybeCache -> + case maybeCache of + Nothing -> + build key cache depsMVar pkg details fingerprint EverySet.empty + + Just (ArtifactCache fingerprints artifacts) -> + if EverySet.member toComparableFingerprint fingerprint fingerprints then + Task.fmap (\_ -> Ok artifacts) (Reporting.report key Reporting.DBuilt) + + else + build key cache depsMVar pkg details fingerprint fingerprints + ) + ) + + else + Reporting.report key Reporting.DRequested + |> Task.bind + (\_ -> + downloadPackage cache manager pkg vsn + |> Task.bind + (\result -> + case result of + Err problem -> + Reporting.report key (Reporting.DFailed pkg vsn) + |> Task.fmap (\_ -> Err (Just (Exit.BD_BadDownload pkg vsn problem))) + + Ok () -> + Reporting.report key (Reporting.DReceived pkg vsn) + |> Task.bind (\_ -> build key cache depsMVar pkg details fingerprint EverySet.empty) + ) + ) + ) + + + +-- ARTIFACT CACHE + + +type ArtifactCache + = ArtifactCache (EverySet (List ( ( String, String ), ( Int, Int, Int ) )) Fingerprint) Artifacts + + +type alias Fingerprint = + Dict ( String, String ) Pkg.Name V.Version + + +toComparableFingerprint : Fingerprint -> List ( ( String, String ), ( Int, Int, Int ) ) +toComparableFingerprint fingerprint = + Dict.toList compare fingerprint + |> List.map (Tuple.mapSecond V.toComparable) + + + +-- BUILD + + +build : Reporting.DKey -> Stuff.PackageCache -> MVar (Dict ( String, String ) Pkg.Name (MVar Dep)) -> Pkg.Name -> Solver.Details -> Fingerprint -> EverySet (List ( ( String, String ), ( Int, Int, Int ) )) Fingerprint -> Task Never Dep +build key cache depsMVar pkg (Solver.Details vsn _) f fs = + Outline.read (Stuff.package cache pkg vsn) + |> Task.bind + (\eitherOutline -> + case eitherOutline of + Err _ -> + Reporting.report key Reporting.DBroken + |> Task.fmap (\_ -> Err (Just (Exit.BD_BadBuild pkg vsn f))) + + Ok (Outline.App _) -> + Reporting.report key Reporting.DBroken + |> Task.fmap (\_ -> Err (Just (Exit.BD_BadBuild pkg vsn f))) + + Ok (Outline.Pkg (Outline.PkgOutline _ _ _ _ exposed deps _ _)) -> + Utils.readMVar dictPkgNameMVarDepDecoder depsMVar + |> Task.bind + (\allDeps -> + Utils.mapTraverse identity Pkg.compareName (Utils.readMVar depDecoder) (Dict.intersection compare allDeps deps) + |> Task.bind + (\directDeps -> + case Utils.sequenceDictResult identity Pkg.compareName directDeps of + Err _ -> + Reporting.report key Reporting.DBroken + |> Task.fmap (\_ -> Err Nothing) + + Ok directArtifacts -> + let + src : String + src = + Stuff.package cache pkg vsn ++ "/src" + + foreignDeps : Dict String ModuleName.Raw ForeignInterface + foreignDeps = + gatherForeignInterfaces directArtifacts + + exposedDict : Dict String ModuleName.Raw () + exposedDict = + Utils.mapFromKeys identity (\_ -> ()) (Outline.flattenExposed exposed) + in + getDocsStatus cache pkg vsn + |> Task.bind + (\docsStatus -> + Utils.newEmptyMVar + |> Task.bind + (\mvar -> + Utils.mapTraverseWithKey identity compare (always << fork (BE.maybe statusEncoder) << crawlModule foreignDeps mvar pkg src docsStatus) exposedDict + |> Task.bind + (\mvars -> + Utils.putMVar statusDictEncoder mvar mvars + |> Task.bind (\_ -> Utils.dictMapM_ compare (Utils.readMVar (BD.maybe statusDecoder)) mvars) + |> Task.bind (\_ -> Task.bind (Utils.mapTraverse identity compare (Utils.readMVar (BD.maybe statusDecoder))) (Utils.readMVar statusDictDecoder mvar)) + |> Task.bind + (\maybeStatuses -> + case Utils.sequenceDictMaybe identity compare maybeStatuses of + Nothing -> + Reporting.report key Reporting.DBroken + |> Task.fmap (\_ -> Err (Just (Exit.BD_BadBuild pkg vsn f))) + + Just statuses -> + Utils.newEmptyMVar + |> Task.bind + (\rmvar -> + Utils.mapTraverse identity compare (fork (BE.maybe dResultEncoder) << compile pkg rmvar) statuses + |> Task.bind + (\rmvars -> + Utils.putMVar dictRawMVarMaybeDResultEncoder rmvar rmvars + |> Task.bind (\_ -> Utils.mapTraverse identity compare (Utils.readMVar (BD.maybe dResultDecoder)) rmvars) + |> Task.bind + (\maybeResults -> + case Utils.sequenceDictMaybe identity compare maybeResults of + Nothing -> + Reporting.report key Reporting.DBroken + |> Task.fmap (\_ -> Err (Just (Exit.BD_BadBuild pkg vsn f))) + + Just results -> + let + path : String + path = + Stuff.package cache pkg vsn ++ "/artifacts.dat" + + ifaces : Dict String ModuleName.Raw I.DependencyInterface + ifaces = + gatherInterfaces exposedDict results + + objects : Opt.GlobalGraph + objects = + gatherObjects results + + artifacts : Artifacts + artifacts = + Artifacts ifaces objects + + fingerprints : EverySet (List ( ( String, String ), ( Int, Int, Int ) )) Fingerprint + fingerprints = + EverySet.insert toComparableFingerprint f fs + in + writeDocs cache pkg vsn docsStatus results + |> Task.bind (\_ -> File.writeBinary artifactCacheEncoder path (ArtifactCache fingerprints artifacts)) + |> Task.bind (\_ -> Reporting.report key Reporting.DBuilt) + |> Task.fmap (\_ -> Ok artifacts) + ) + ) + ) + ) + ) + ) + ) + ) + ) + ) + + + +-- GATHER + + +gatherObjects : Dict String ModuleName.Raw DResult -> Opt.GlobalGraph +gatherObjects results = + Dict.foldr compare addLocalGraph Opt.empty results + + +addLocalGraph : ModuleName.Raw -> DResult -> Opt.GlobalGraph -> Opt.GlobalGraph +addLocalGraph name status graph = + case status of + RLocal _ objs _ -> + Opt.addLocalGraph objs graph + + RForeign _ -> + graph + + RKernelLocal cs -> + Opt.addKernel (Name.getKernel name) cs graph + + RKernelForeign -> + graph + + +gatherInterfaces : Dict String ModuleName.Raw () -> Dict String ModuleName.Raw DResult -> Dict String ModuleName.Raw I.DependencyInterface +gatherInterfaces exposed artifacts = + let + onLeft : a -> b -> c -> d + onLeft _ _ _ = + crash "compiler bug manifesting in Elm.Details.gatherInterfaces" + + onBoth : comparable -> () -> DResult -> Dict comparable comparable I.DependencyInterface -> Dict comparable comparable I.DependencyInterface + onBoth k () iface = + toLocalInterface I.public iface + |> Maybe.map (Dict.insert identity k) + |> Maybe.withDefault identity + + onRight : comparable -> DResult -> Dict comparable comparable I.DependencyInterface -> Dict comparable comparable I.DependencyInterface + onRight k iface = + toLocalInterface I.private iface + |> Maybe.map (Dict.insert identity k) + |> Maybe.withDefault identity + in + Dict.merge compare onLeft onBoth onRight exposed artifacts Dict.empty + + +toLocalInterface : (I.Interface -> a) -> DResult -> Maybe a +toLocalInterface func result = + case result of + RLocal iface _ _ -> + Just (func iface) + + RForeign _ -> + Nothing + + RKernelLocal _ -> + Nothing + + RKernelForeign -> + Nothing + + + +-- GATHER FOREIGN INTERFACES + + +type ForeignInterface + = ForeignAmbiguous + | ForeignSpecific I.Interface + + +gatherForeignInterfaces : Dict ( String, String ) Pkg.Name Artifacts -> Dict String ModuleName.Raw ForeignInterface +gatherForeignInterfaces directArtifacts = + let + finalize : I.Interface -> List I.Interface -> ForeignInterface + finalize i is = + case is of + [] -> + ForeignSpecific i + + _ :: _ -> + ForeignAmbiguous + + gather : Pkg.Name -> Artifacts -> Dict String ModuleName.Raw (OneOrMore.OneOrMore I.Interface) -> Dict String ModuleName.Raw (OneOrMore.OneOrMore I.Interface) + gather _ (Artifacts ifaces _) buckets = + Utils.mapUnionWith identity compare OneOrMore.more buckets (Utils.mapMapMaybe identity compare isPublic ifaces) + + isPublic : I.DependencyInterface -> Maybe (OneOrMore.OneOrMore I.Interface) + isPublic di = + case di of + I.Public iface -> + Just (OneOrMore.one iface) + + I.Private _ _ _ -> + Nothing + in + Dict.map (\_ -> OneOrMore.destruct finalize) <| + Dict.foldr compare gather Dict.empty directArtifacts + + + +-- CRAWL + + +type alias StatusDict = + Dict String ModuleName.Raw (MVar (Maybe Status)) + + +type Status + = SLocal DocsStatus (Dict String ModuleName.Raw ()) Src.Module + | SForeign I.Interface + | SKernelLocal (List Kernel.Chunk) + | SKernelForeign + + +crawlModule : Dict String ModuleName.Raw ForeignInterface -> MVar StatusDict -> Pkg.Name -> FilePath -> DocsStatus -> ModuleName.Raw -> Task Never (Maybe Status) +crawlModule foreignDeps mvar pkg src docsStatus name = + let + path : String -> FilePath + path extension = + Utils.fpCombine src (Utils.fpAddExtension (ModuleName.toFilePath name) extension) + + guidaPath : FilePath + guidaPath = + path "guida" + + elmPath : FilePath + elmPath = + path "elm" + in + File.exists guidaPath + |> Task.bind + (\guidaExists -> + File.exists elmPath + |> Task.bind + (\elmExists -> + case Dict.get identity name foreignDeps of + Just ForeignAmbiguous -> + Task.pure Nothing + + Just (ForeignSpecific iface) -> + if guidaExists || elmExists then + Task.pure Nothing + + else + Task.pure (Just (SForeign iface)) + + Nothing -> + if guidaExists then + crawlFile SV.Guida foreignDeps mvar pkg src docsStatus name guidaPath + + else if elmExists then + crawlFile SV.Elm foreignDeps mvar pkg src docsStatus name elmPath + + else if Pkg.isKernel pkg && Name.isKernel name then + crawlKernel foreignDeps mvar pkg src name + + else + Task.pure Nothing + ) + ) + + +crawlFile : SyntaxVersion -> Dict String ModuleName.Raw ForeignInterface -> MVar StatusDict -> Pkg.Name -> FilePath -> DocsStatus -> ModuleName.Raw -> FilePath -> Task Never (Maybe Status) +crawlFile syntaxVersion foreignDeps mvar pkg src docsStatus expectedName path = + File.readUtf8 path + |> Task.bind + (\bytes -> + case Parse.fromByteString syntaxVersion (Parse.Package pkg) bytes of + Ok ((Src.Module _ (Just (A.At _ actualName)) _ _ imports _ _ _ _ _) as modul) -> + if expectedName == actualName then + crawlImports foreignDeps mvar pkg src imports + |> Task.fmap (\deps -> Just (SLocal docsStatus deps modul)) + + else + Task.pure Nothing + + _ -> + Task.pure Nothing + ) + + +crawlImports : Dict String ModuleName.Raw ForeignInterface -> MVar StatusDict -> Pkg.Name -> FilePath -> List Src.Import -> Task Never (Dict String ModuleName.Raw ()) +crawlImports foreignDeps mvar pkg src imports = + Utils.takeMVar statusDictDecoder mvar + |> Task.bind + (\statusDict -> + let + deps : Dict String Name.Name () + deps = + Dict.fromList identity (List.map (\i -> ( Src.getImportName i, () )) imports) + + news : Dict String Name.Name () + news = + Dict.diff deps statusDict + in + Utils.mapTraverseWithKey identity compare (always << fork (BE.maybe statusEncoder) << crawlModule foreignDeps mvar pkg src DocsNotNeeded) news + |> Task.bind + (\mvars -> + Utils.putMVar statusDictEncoder mvar (Dict.union mvars statusDict) + |> Task.bind (\_ -> Utils.dictMapM_ compare (Utils.readMVar (BD.maybe statusDecoder)) mvars) + |> Task.fmap (\_ -> deps) + ) + ) + + +crawlKernel : Dict String ModuleName.Raw ForeignInterface -> MVar StatusDict -> Pkg.Name -> FilePath -> ModuleName.Raw -> Task Never (Maybe Status) +crawlKernel foreignDeps mvar pkg src name = + let + path : FilePath + path = + Utils.fpCombine src (Utils.fpAddExtension (ModuleName.toFilePath name) "js") + in + File.exists path + |> Task.bind + (\exists -> + if exists then + File.readUtf8 path + |> Task.bind + (\bytes -> + case Kernel.fromByteString pkg (Utils.mapMapMaybe identity compare getDepHome foreignDeps) bytes of + Nothing -> + Task.pure Nothing + + Just (Kernel.Content imports chunks) -> + crawlImports foreignDeps mvar pkg src (List.map Src.c1Value imports) + |> Task.fmap (\_ -> Just (SKernelLocal chunks)) + ) + + else + Task.pure (Just SKernelForeign) + ) + + +getDepHome : ForeignInterface -> Maybe Pkg.Name +getDepHome fi = + case fi of + ForeignSpecific (I.Interface pkg _ _ _ _) -> + Just pkg + + ForeignAmbiguous -> + Nothing + + + +-- COMPILE + + +type DResult + = RLocal I.Interface Opt.LocalGraph (Maybe Docs.Module) + | RForeign I.Interface + | RKernelLocal (List Kernel.Chunk) + | RKernelForeign + + +compile : Pkg.Name -> MVar (Dict String ModuleName.Raw (MVar (Maybe DResult))) -> Status -> Task Never (Maybe DResult) +compile pkg mvar status = + case status of + SLocal docsStatus deps modul -> + Utils.readMVar moduleNameRawMVarMaybeDResultDecoder mvar + |> Task.bind + (\resultsDict -> + Utils.mapTraverse identity compare (Utils.readMVar (BD.maybe dResultDecoder)) (Dict.intersection compare resultsDict deps) + |> Task.bind + (\maybeResults -> + case Utils.sequenceDictMaybe identity compare maybeResults of + Just results -> + Compile.compile pkg (Utils.mapMapMaybe identity compare getInterface results) modul + |> Task.fmap + (\result -> + case result of + Err _ -> + Nothing + + Ok (Compile.Artifacts canonical annotations objects) -> + let + ifaces : I.Interface + ifaces = + I.fromModule pkg canonical annotations + + docs : Maybe Docs.Module + docs = + makeDocs docsStatus canonical + in + Just (RLocal ifaces objects docs) + ) + + Nothing -> + Task.pure Nothing + ) + ) + + SForeign iface -> + Task.pure (Just (RForeign iface)) + + SKernelLocal chunks -> + Task.pure (Just (RKernelLocal chunks)) + + SKernelForeign -> + Task.pure (Just RKernelForeign) + + +getInterface : DResult -> Maybe I.Interface +getInterface result = + case result of + RLocal iface _ _ -> + Just iface + + RForeign iface -> + Just iface + + RKernelLocal _ -> + Nothing + + RKernelForeign -> + Nothing + + + +-- MAKE DOCS + + +type DocsStatus + = DocsNeeded + | DocsNotNeeded + + +getDocsStatus : Stuff.PackageCache -> Pkg.Name -> V.Version -> Task Never DocsStatus +getDocsStatus cache pkg vsn = + File.exists (Stuff.package cache pkg vsn ++ "/docs.json") + |> Task.fmap + (\exists -> + if exists then + DocsNotNeeded + + else + DocsNeeded + ) + + +makeDocs : DocsStatus -> Can.Module -> Maybe Docs.Module +makeDocs status modul = + case status of + DocsNeeded -> + case Docs.fromModule modul of + Ok docs -> + Just docs + + Err _ -> + Nothing + + DocsNotNeeded -> + Nothing + + +writeDocs : Stuff.PackageCache -> Pkg.Name -> V.Version -> DocsStatus -> Dict String ModuleName.Raw DResult -> Task Never () +writeDocs cache pkg vsn status results = + case status of + DocsNeeded -> + E.writeUgly (Stuff.package cache pkg vsn ++ "/docs.json") + (Docs.encode (Utils.mapMapMaybe identity compare toDocs results)) + + DocsNotNeeded -> + Task.pure () + + +toDocs : DResult -> Maybe Docs.Module +toDocs result = + case result of + RLocal _ _ docs -> + docs + + RForeign _ -> + Nothing + + RKernelLocal _ -> + Nothing + + RKernelForeign -> + Nothing + + + +-- DOWNLOAD PACKAGE + + +downloadPackage : Stuff.PackageCache -> Http.Manager -> Pkg.Name -> V.Version -> Task Never (Result Exit.PackageProblem ()) +downloadPackage cache manager pkg vsn = + Website.metadata pkg vsn "endpoint.json" + |> Task.bind + (\url -> + Http.get manager url [] identity (Task.pure << Ok) + |> Task.bind + (\eitherByteString -> + case eitherByteString of + Err err -> + Task.pure (Err (Exit.PP_BadEndpointRequest err)) + + Ok byteString -> + case D.fromByteString endpointDecoder byteString of + Err _ -> + Task.pure (Err (Exit.PP_BadEndpointContent url)) + + Ok ( endpoint, expectedHash ) -> + Http.getArchive manager endpoint Exit.PP_BadArchiveRequest (Exit.PP_BadArchiveContent endpoint) <| + \( sha, archive ) -> + if expectedHash == Http.shaToChars sha then + Task.fmap Ok (File.writePackage (Stuff.package cache pkg vsn) archive) + + else + Task.pure (Err (Exit.PP_BadArchiveHash endpoint expectedHash (Http.shaToChars sha))) + ) + ) + + +endpointDecoder : D.Decoder e ( String, String ) +endpointDecoder = + D.field "url" D.string + |> D.bind + (\url -> + D.field "hash" D.string + |> D.fmap (\hash -> ( url, hash )) + ) + + + +-- ENCODERS and DECODERS + + +detailsEncoder : Details -> BE.Encoder +detailsEncoder (Details oldTime outline buildID locals foreigns extras) = + BE.sequence + [ File.timeEncoder oldTime + , validOutlineEncoder outline + , BE.int buildID + , BE.assocListDict compare ModuleName.rawEncoder localEncoder locals + , BE.assocListDict compare ModuleName.rawEncoder foreignEncoder foreigns + , extrasEncoder extras + ] + + +detailsDecoder : BD.Decoder Details +detailsDecoder = + BD.map6 Details + File.timeDecoder + validOutlineDecoder + BD.int + (BD.assocListDict identity ModuleName.rawDecoder localDecoder) + (BD.assocListDict identity ModuleName.rawDecoder foreignDecoder) + extrasDecoder + + +interfacesEncoder : Interfaces -> BE.Encoder +interfacesEncoder = + BE.assocListDict ModuleName.compareCanonical ModuleName.canonicalEncoder I.dependencyInterfaceEncoder + + +interfacesDecoder : BD.Decoder Interfaces +interfacesDecoder = + BD.assocListDict ModuleName.toComparableCanonical ModuleName.canonicalDecoder I.dependencyInterfaceDecoder + + +resultRegistryProblemEnvEncoder : Result Exit.RegistryProblem Solver.Env -> BE.Encoder +resultRegistryProblemEnvEncoder = + BE.result Exit.registryProblemEncoder Solver.envEncoder + + +resultRegistryProblemEnvDecoder : BD.Decoder (Result Exit.RegistryProblem Solver.Env) +resultRegistryProblemEnvDecoder = + BD.result Exit.registryProblemDecoder Solver.envDecoder + + +depEncoder : Dep -> BE.Encoder +depEncoder dep = + BE.result (BE.maybe Exit.detailsBadDepEncoder) artifactsEncoder dep + + +depDecoder : BD.Decoder Dep +depDecoder = + BD.result (BD.maybe Exit.detailsBadDepDecoder) artifactsDecoder + + +artifactsEncoder : Artifacts -> BE.Encoder +artifactsEncoder (Artifacts ifaces objects) = + BE.sequence + [ BE.assocListDict compare ModuleName.rawEncoder I.dependencyInterfaceEncoder ifaces + , Opt.globalGraphEncoder objects + ] + + +artifactsDecoder : BD.Decoder Artifacts +artifactsDecoder = + BD.map2 Artifacts + (BD.assocListDict identity ModuleName.rawDecoder I.dependencyInterfaceDecoder) + Opt.globalGraphDecoder + + +dictNameMVarDepEncoder : Dict ( String, String ) Pkg.Name (MVar Dep) -> BE.Encoder +dictNameMVarDepEncoder = + BE.assocListDict compare Pkg.nameEncoder Utils.mVarEncoder + + +artifactCacheEncoder : ArtifactCache -> BE.Encoder +artifactCacheEncoder (ArtifactCache fingerprints artifacts) = + BE.sequence + [ BE.everySet (\_ _ -> EQ) fingerprintEncoder fingerprints + , artifactsEncoder artifacts + ] + + +artifactCacheDecoder : BD.Decoder ArtifactCache +artifactCacheDecoder = + BD.map2 ArtifactCache + (BD.everySet toComparableFingerprint fingerprintDecoder) + artifactsDecoder + + +dictPkgNameMVarDepDecoder : BD.Decoder (Dict ( String, String ) Pkg.Name (MVar Dep)) +dictPkgNameMVarDepDecoder = + BD.assocListDict identity Pkg.nameDecoder Utils.mVarDecoder + + +statusEncoder : Status -> BE.Encoder +statusEncoder status = + case status of + SLocal docsStatus deps modul -> + BE.sequence + [ BE.unsignedInt8 0 + , docsStatusEncoder docsStatus + , BE.list ModuleName.rawEncoder (Dict.keys compare deps) + , Src.moduleEncoder modul + ] + + SForeign iface -> + BE.sequence + [ BE.unsignedInt8 1 + , I.interfaceEncoder iface + ] + + SKernelLocal chunks -> + BE.sequence + [ BE.unsignedInt8 2 + , BE.list Kernel.chunkEncoder chunks + ] + + SKernelForeign -> + BE.unsignedInt8 3 + + +statusDecoder : BD.Decoder Status +statusDecoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.map3 SLocal + docsStatusDecoder + (BD.list ModuleName.rawDecoder + |> BD.map (Dict.fromList identity << List.map (\dep -> ( dep, () ))) + ) + Src.moduleDecoder + + 1 -> + BD.map SForeign I.interfaceDecoder + + 2 -> + BD.map SKernelLocal (BD.list Kernel.chunkDecoder) + + 3 -> + BD.succeed SKernelForeign + + _ -> + BD.fail + ) + + +dictRawMVarMaybeDResultEncoder : Dict String ModuleName.Raw (MVar (Maybe DResult)) -> BE.Encoder +dictRawMVarMaybeDResultEncoder = + BE.assocListDict compare ModuleName.rawEncoder Utils.mVarEncoder + + +moduleNameRawMVarMaybeDResultDecoder : BD.Decoder (Dict String ModuleName.Raw (MVar (Maybe DResult))) +moduleNameRawMVarMaybeDResultDecoder = + BD.assocListDict identity ModuleName.rawDecoder Utils.mVarDecoder + + +dResultEncoder : DResult -> BE.Encoder +dResultEncoder dResult = + case dResult of + RLocal ifaces objects docs -> + BE.sequence + [ BE.unsignedInt8 0 + , I.interfaceEncoder ifaces + , Opt.localGraphEncoder objects + , BE.maybe Docs.bytesModuleEncoder docs + ] + + RForeign iface -> + BE.sequence + [ BE.unsignedInt8 1 + , I.interfaceEncoder iface + ] + + RKernelLocal chunks -> + BE.sequence + [ BE.unsignedInt8 2 + , BE.list Kernel.chunkEncoder chunks + ] + + RKernelForeign -> + BE.unsignedInt8 3 + + +dResultDecoder : BD.Decoder DResult +dResultDecoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.map3 RLocal + I.interfaceDecoder + Opt.localGraphDecoder + (BD.maybe Docs.bytesModuleDecoder) + + 1 -> + BD.map RForeign I.interfaceDecoder + + 2 -> + BD.map RKernelLocal (BD.list Kernel.chunkDecoder) + + 3 -> + BD.succeed RKernelForeign + + _ -> + BD.fail + ) + + +statusDictEncoder : StatusDict -> BE.Encoder +statusDictEncoder statusDict = + BE.assocListDict compare ModuleName.rawEncoder Utils.mVarEncoder statusDict + + +statusDictDecoder : BD.Decoder StatusDict +statusDictDecoder = + BD.assocListDict identity ModuleName.rawDecoder Utils.mVarDecoder + + +localEncoder : Local -> BE.Encoder +localEncoder (Local path time deps hasMain lastChange lastCompile) = + BE.sequence + [ BE.string path + , File.timeEncoder time + , BE.list ModuleName.rawEncoder deps + , BE.bool hasMain + , BE.int lastChange + , BE.int lastCompile + ] + + +localDecoder : BD.Decoder Local +localDecoder = + BD.map6 Local + BD.string + File.timeDecoder + (BD.list ModuleName.rawDecoder) + BD.bool + BD.int + BD.int + + +validOutlineEncoder : ValidOutline -> BE.Encoder +validOutlineEncoder validOutline = + case validOutline of + ValidApp srcDirs -> + BE.sequence + [ BE.unsignedInt8 0 + , BE.nonempty Outline.srcDirEncoder srcDirs + ] + + ValidPkg pkg exposedList exactDeps -> + BE.sequence + [ BE.unsignedInt8 1 + , Pkg.nameEncoder pkg + , BE.list ModuleName.rawEncoder exposedList + , BE.assocListDict compare Pkg.nameEncoder V.versionEncoder exactDeps + ] + + +validOutlineDecoder : BD.Decoder ValidOutline +validOutlineDecoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.map ValidApp (BD.nonempty Outline.srcDirDecoder) + + 1 -> + BD.map3 ValidPkg + Pkg.nameDecoder + (BD.list ModuleName.rawDecoder) + (BD.assocListDict identity Pkg.nameDecoder V.versionDecoder) + + _ -> + BD.fail + ) + + +foreignEncoder : Foreign -> BE.Encoder +foreignEncoder (Foreign dep deps) = + BE.sequence + [ Pkg.nameEncoder dep + , BE.list Pkg.nameEncoder deps + ] + + +foreignDecoder : BD.Decoder Foreign +foreignDecoder = + BD.map2 Foreign + Pkg.nameDecoder + (BD.list Pkg.nameDecoder) + + +extrasEncoder : Extras -> BE.Encoder +extrasEncoder extras = + case extras of + ArtifactsCached -> + BE.unsignedInt8 0 + + ArtifactsFresh ifaces objs -> + BE.sequence + [ BE.unsignedInt8 1 + , interfacesEncoder ifaces + , Opt.globalGraphEncoder objs + ] + + +extrasDecoder : BD.Decoder Extras +extrasDecoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.succeed ArtifactsCached + + 1 -> + BD.map2 ArtifactsFresh + interfacesDecoder + Opt.globalGraphDecoder + + _ -> + BD.fail + ) + + +fingerprintEncoder : Fingerprint -> BE.Encoder +fingerprintEncoder = + BE.assocListDict compare Pkg.nameEncoder V.versionEncoder + + +fingerprintDecoder : BD.Decoder Fingerprint +fingerprintDecoder = + BD.assocListDict identity Pkg.nameDecoder V.versionDecoder + + +docsStatusEncoder : DocsStatus -> BE.Encoder +docsStatusEncoder docsStatus = + BE.unsignedInt8 + (case docsStatus of + DocsNeeded -> + 0 + + DocsNotNeeded -> + 1 + ) + + +docsStatusDecoder : BD.Decoder DocsStatus +docsStatusDecoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.succeed DocsNeeded + + 1 -> + BD.succeed DocsNotNeeded + + _ -> + BD.fail + ) diff --git a/src/Builder/Elm/Outline.elm b/src/Builder/Elm/Outline.elm new file mode 100644 index 0000000000..b2eb1dcb73 --- /dev/null +++ b/src/Builder/Elm/Outline.elm @@ -0,0 +1,567 @@ +module Builder.Elm.Outline exposing + ( AppOutline(..) + , Decoder + , Exposed(..) + , Outline(..) + , PkgOutline(..) + , SrcDir(..) + , decoder + , defaultSummary + , flattenExposed + , getAllModulePaths + , read + , srcDirDecoder + , srcDirEncoder + , write + ) + +import Basics.Extra as Basics +import Builder.File as File +import Builder.Reporting.Exit as Exit +import Builder.Stuff as Stuff +import Compiler.Data.Name as Name +import Compiler.Data.NonEmptyList as NE +import Compiler.Data.OneOrMore as OneOrMore +import Compiler.Elm.Constraint as Con +import Compiler.Elm.Licenses as Licenses +import Compiler.Elm.ModuleName as ModuleName +import Compiler.Elm.Package as Pkg +import Compiler.Elm.Version as V +import Compiler.Json.Decode as D +import Compiler.Json.Encode as E +import Compiler.Parse.Primitives as P +import Data.Map as Dict exposing (Dict) +import System.TypeCheck.IO as TypeCheck +import Task exposing (Task) +import Utils.Bytes.Decode as BD +import Utils.Bytes.Encode as BE +import Utils.Main as Utils exposing (FilePath) +import Utils.Task.Extra as Task + + + +-- OUTLINE + + +type Outline + = App AppOutline + | Pkg PkgOutline + + +type AppOutline + = AppOutline V.Version (NE.Nonempty SrcDir) (Dict ( String, String ) Pkg.Name V.Version) (Dict ( String, String ) Pkg.Name V.Version) (Dict ( String, String ) Pkg.Name V.Version) (Dict ( String, String ) Pkg.Name V.Version) + + +type PkgOutline + = PkgOutline Pkg.Name String Licenses.License V.Version Exposed (Dict ( String, String ) Pkg.Name Con.Constraint) (Dict ( String, String ) Pkg.Name Con.Constraint) Con.Constraint + + +type Exposed + = ExposedList (List ModuleName.Raw) + | ExposedDict (List ( String, List ModuleName.Raw )) + + +type SrcDir + = AbsoluteSrcDir FilePath + | RelativeSrcDir FilePath + + + +-- DEFAULTS + + +defaultSummary : String +defaultSummary = + "helpful summary of your project, less than 80 characters" + + + +-- HELPERS + + +flattenExposed : Exposed -> List ModuleName.Raw +flattenExposed exposed = + case exposed of + ExposedList names -> + names + + ExposedDict sections -> + List.concatMap Tuple.second sections + + + +-- WRITE + + +write : FilePath -> Outline -> Task Never () +write root outline = + E.write (root ++ "/elm.json") (encode outline) + + + +-- JSON ENCODE + + +encode : Outline -> E.Value +encode outline = + case outline of + App (AppOutline elm srcDirs depsDirect depsTrans testDirect testTrans) -> + E.object + [ ( "type", E.string "application" ) + , ( "source-directories", E.list encodeSrcDir (NE.toList srcDirs) ) + , ( "elm-version", V.encode elm ) + , ( "dependencies" + , E.object + [ ( "direct", encodeDeps V.encode depsDirect ) + , ( "indirect", encodeDeps V.encode depsTrans ) + ] + ) + , ( "test-dependencies" + , E.object + [ ( "direct", encodeDeps V.encode testDirect ) + , ( "indirect", encodeDeps V.encode testTrans ) + ] + ) + ] + + Pkg (PkgOutline name summary license version exposed deps tests elm) -> + E.object + [ ( "type", E.string "package" ) + , ( "name", Pkg.encode name ) + , ( "summary", E.string summary ) + , ( "license", Licenses.encode license ) + , ( "version", V.encode version ) + , ( "exposed-modules", encodeExposed exposed ) + , ( "elm-version", Con.encode elm ) + , ( "dependencies", encodeDeps Con.encode deps ) + , ( "test-dependencies", encodeDeps Con.encode tests ) + ] + + +encodeExposed : Exposed -> E.Value +encodeExposed exposed = + case exposed of + ExposedList modules -> + E.list encodeModule modules + + ExposedDict chunks -> + E.object (List.map (Tuple.mapSecond (E.list encodeModule)) chunks) + + +encodeModule : ModuleName.Raw -> E.Value +encodeModule name = + E.name name + + +encodeDeps : (a -> E.Value) -> Dict ( String, String ) Pkg.Name a -> E.Value +encodeDeps encodeValue deps = + E.dict Pkg.compareName Pkg.toJsonString encodeValue deps + + +encodeSrcDir : SrcDir -> E.Value +encodeSrcDir srcDir = + case srcDir of + AbsoluteSrcDir dir -> + E.string dir + + RelativeSrcDir dir -> + E.string dir + + + +-- PARSE AND VERIFY + + +read : FilePath -> Task Never (Result Exit.Outline Outline) +read root = + File.readUtf8 (root ++ "/elm.json") + |> Task.bind + (\bytes -> + case D.fromByteString decoder bytes of + Err err -> + Task.pure <| Err (Exit.OutlineHasBadStructure err) + + Ok outline -> + case outline of + Pkg (PkgOutline pkg _ _ _ _ deps _ _) -> + Task.pure <| + if not (Dict.member identity Pkg.core deps) && pkg /= Pkg.core then + Err Exit.OutlineNoPkgCore + + else + Ok outline + + App (AppOutline _ srcDirs direct indirect _ _) -> + if not (Dict.member identity Pkg.core direct) then + Task.pure <| Err Exit.OutlineNoAppCore + + else if not (Dict.member identity Pkg.json direct) && not (Dict.member identity Pkg.json indirect) then + Task.pure <| Err Exit.OutlineNoAppJson + + else + Utils.filterM (isSrcDirMissing root) (NE.toList srcDirs) + |> Task.bind + (\badDirs -> + case List.map toGiven badDirs of + d :: ds -> + Task.pure <| Err (Exit.OutlineHasMissingSrcDirs d ds) + + [] -> + detectDuplicates root (NE.toList srcDirs) + |> Task.bind + (\maybeDups -> + case maybeDups of + Nothing -> + Task.pure <| Ok outline + + Just ( canonicalDir, ( dir1, dir2 ) ) -> + Task.pure <| Err (Exit.OutlineHasDuplicateSrcDirs canonicalDir dir1 dir2) + ) + ) + ) + + +isSrcDirMissing : FilePath -> SrcDir -> Task Never Bool +isSrcDirMissing root srcDir = + Task.fmap not (Utils.dirDoesDirectoryExist (toAbsolute root srcDir)) + + +toGiven : SrcDir -> FilePath +toGiven srcDir = + case srcDir of + AbsoluteSrcDir dir -> + dir + + RelativeSrcDir dir -> + dir + + +toAbsolute : FilePath -> SrcDir -> FilePath +toAbsolute root srcDir = + case srcDir of + AbsoluteSrcDir dir -> + dir + + RelativeSrcDir dir -> + Utils.fpCombine root dir + + +detectDuplicates : FilePath -> List SrcDir -> Task Never (Maybe ( FilePath, ( FilePath, FilePath ) )) +detectDuplicates root srcDirs = + Utils.listTraverse (toPair root) srcDirs + |> Task.fmap + (\pairs -> + Utils.mapLookupMin <| + Utils.mapMapMaybe identity compare isDup <| + Utils.mapFromListWith identity OneOrMore.more pairs + ) + + +toPair : FilePath -> SrcDir -> Task Never ( FilePath, OneOrMore.OneOrMore FilePath ) +toPair root srcDir = + Utils.dirCanonicalizePath (toAbsolute root srcDir) + |> Task.bind + (\key -> + Task.pure ( key, OneOrMore.one (toGiven srcDir) ) + ) + + +isDup : OneOrMore.OneOrMore FilePath -> Maybe ( FilePath, FilePath ) +isDup paths = + case paths of + OneOrMore.One _ -> + Nothing + + OneOrMore.More a b -> + Just (OneOrMore.getFirstTwo a b) + + + +-- GET ALL MODULE PATHS + + +getAllModulePaths : FilePath -> Task Never (Dict (List String) TypeCheck.Canonical FilePath) +getAllModulePaths root = + read root + |> Task.bind + (\outlineResult -> + case outlineResult of + Err _ -> + Task.pure Dict.empty + + Ok outline -> + case outline of + App (AppOutline _ srcDirs depsDirect indirect _ _) -> + let + deps : Dict ( String, String ) Pkg.Name V.Version + deps = + Dict.union depsDirect indirect + + absoluteSrcDirs : List FilePath + absoluteSrcDirs = + List.map (toAbsolute root) (NE.toList srcDirs) + in + getAllModulePathsHelper Pkg.dummyName absoluteSrcDirs deps + + Pkg (PkgOutline name _ _ _ _ pkgDeps _ _) -> + let + deps : Dict ( String, String ) Pkg.Name V.Version + deps = + Dict.map (\_ -> Con.lowerBound) pkgDeps + in + getAllModulePathsHelper name [ root ++ "/src" ] deps + ) + + +getAllModulePathsHelper : Pkg.Name -> List FilePath -> Dict ( String, String ) Pkg.Name V.Version -> Task Never (Dict (List String) TypeCheck.Canonical FilePath) +getAllModulePathsHelper packageName packageSrcDirs deps = + Utils.listTraverse recursiveFindFiles packageSrcDirs + |> Task.bind + (\files -> + Utils.mapTraverseWithKey identity compare resolvePackagePaths deps + |> Task.bind + (\dependencyRoots -> + Utils.mapTraverse identity compare (\( pkgName, pkgRoot ) -> getAllModulePathsHelper pkgName [ pkgRoot ++ "/src" ] Dict.empty) dependencyRoots + |> Task.fmap + (\dependencyMaps -> + let + asMap : Dict (List String) TypeCheck.Canonical FilePath + asMap = + List.concat files + |> List.map (\( root, fp ) -> ( TypeCheck.Canonical packageName (moduleNameFromFilePath root fp), fp )) + |> Dict.fromList ModuleName.toComparableCanonical + in + Dict.foldr compare (\_ -> Dict.union) asMap dependencyMaps + ) + ) + ) + + +recursiveFindFiles : FilePath -> Task Never (List ( FilePath, FilePath )) +recursiveFindFiles root = + recursiveFindFilesHelp root + |> Task.fmap (List.map (Tuple.pair root)) + + +recursiveFindFilesHelp : FilePath -> Task Never (List FilePath) +recursiveFindFilesHelp root = + Utils.dirListDirectory root + |> Task.bind + (\dirContents -> + let + ( elmFiles, ( guidaFiles, others ) ) = + List.partition (hasExtension ".elm") dirContents + |> Tuple.mapSecond (List.partition (hasExtension ".guida")) + in + Utils.filterM (\fp -> Utils.dirDoesDirectoryExist (root ++ "/" ++ fp)) others + |> Task.bind + (\subDirectories -> + Utils.listTraverse (\subDirectory -> recursiveFindFilesHelp (root ++ "/" ++ subDirectory)) subDirectories + |> Task.fmap + (\filesFromSubDirs -> + List.concat filesFromSubDirs ++ List.map (\fp -> root ++ "/" ++ fp) (elmFiles ++ guidaFiles) + ) + ) + ) + + +hasExtension : String -> FilePath -> Bool +hasExtension ext path = + ext == Utils.fpTakeExtension path + + +moduleNameFromFilePath : FilePath -> FilePath -> Name.Name +moduleNameFromFilePath root filePath = + filePath + |> String.dropLeft (String.length root + 1) + |> Utils.fpDropExtension + |> String.replace "/" "." + + +resolvePackagePaths : Pkg.Name -> V.Version -> Task Never ( Pkg.Name, FilePath ) +resolvePackagePaths pkgName vsn = + Stuff.getPackageCache + |> Task.fmap (\packageCache -> ( pkgName, Stuff.package packageCache pkgName vsn )) + + + +-- JSON DECODE + + +type alias Decoder a = + D.Decoder Exit.OutlineProblem a + + +decoder : Decoder Outline +decoder = + let + application : String + application = + "application" + + package : String + package = + "package" + in + D.field "type" D.string + |> D.bind + (\tipe -> + if tipe == application then + D.fmap App appDecoder + + else if tipe == package then + D.fmap Pkg pkgDecoder + + else + D.failure Exit.OP_BadType + ) + + +appDecoder : Decoder AppOutline +appDecoder = + D.pure AppOutline + |> D.apply (D.field "elm-version" versionDecoder) + |> D.apply (D.field "source-directories" dirsDecoder) + |> D.apply (D.field "dependencies" (D.field "direct" (depsDecoder versionDecoder))) + |> D.apply (D.field "dependencies" (D.field "indirect" (depsDecoder versionDecoder))) + |> D.apply (D.field "test-dependencies" (D.field "direct" (depsDecoder versionDecoder))) + |> D.apply (D.field "test-dependencies" (D.field "indirect" (depsDecoder versionDecoder))) + + +pkgDecoder : Decoder PkgOutline +pkgDecoder = + D.pure PkgOutline + |> D.apply (D.field "name" nameDecoder) + |> D.apply (D.field "summary" summaryDecoder) + |> D.apply (D.field "license" (Licenses.decoder Exit.OP_BadLicense)) + |> D.apply (D.field "version" versionDecoder) + |> D.apply (D.field "exposed-modules" exposedDecoder) + |> D.apply (D.field "dependencies" (depsDecoder constraintDecoder)) + |> D.apply (D.field "test-dependencies" (depsDecoder constraintDecoder)) + |> D.apply (D.field "elm-version" constraintDecoder) + + + +-- JSON DECODE HELPERS + + +nameDecoder : Decoder Pkg.Name +nameDecoder = + D.mapError (Basics.uncurry Exit.OP_BadPkgName) Pkg.decoder + + +summaryDecoder : Decoder String +summaryDecoder = + D.customString + (boundParser 80 Exit.OP_BadSummaryTooLong) + (\_ _ -> Exit.OP_BadSummaryTooLong) + + +versionDecoder : Decoder V.Version +versionDecoder = + D.mapError (Basics.uncurry Exit.OP_BadVersion) V.decoder + + +constraintDecoder : Decoder Con.Constraint +constraintDecoder = + D.mapError Exit.OP_BadConstraint Con.decoder + + +depsDecoder : Decoder a -> Decoder (Dict ( String, String ) Pkg.Name a) +depsDecoder valueDecoder = + D.dict identity (Pkg.keyDecoder Exit.OP_BadDependencyName) valueDecoder + + +dirsDecoder : Decoder (NE.Nonempty SrcDir) +dirsDecoder = + D.fmap (NE.map toSrcDir) (D.nonEmptyList D.string Exit.OP_NoSrcDirs) + + +toSrcDir : FilePath -> SrcDir +toSrcDir path = + if Utils.fpIsRelative path then + RelativeSrcDir path + + else + AbsoluteSrcDir path + + + +-- EXPOSED MODULES DECODER + + +exposedDecoder : Decoder Exposed +exposedDecoder = + D.oneOf + [ D.fmap ExposedList (D.list moduleDecoder) + , D.fmap ExposedDict (D.pairs headerKeyDecoder (D.list moduleDecoder)) + ] + + +moduleDecoder : Decoder ModuleName.Raw +moduleDecoder = + D.mapError (Basics.uncurry Exit.OP_BadModuleName) ModuleName.decoder + + +headerKeyDecoder : D.KeyDecoder Exit.OutlineProblem String +headerKeyDecoder = + D.KeyDecoder + (boundParser 20 Exit.OP_BadModuleHeaderTooLong) + (\_ _ -> Exit.OP_BadModuleHeaderTooLong) + + + +-- BOUND PARSER + + +boundParser : Int -> x -> P.Parser x String +boundParser bound tooLong = + P.Parser <| + \(P.State src pos end indent row col) -> + let + len : Int + len = + end - pos + + newCol : P.Col + newCol = + col + len + in + if len < bound then + P.Cok (String.slice pos end src) (P.State src end end indent row newCol) + + else + P.Cerr row newCol (\_ _ -> tooLong) + + +srcDirEncoder : SrcDir -> BE.Encoder +srcDirEncoder srcDir = + case srcDir of + AbsoluteSrcDir dir -> + BE.sequence + [ BE.unsignedInt8 0 + , BE.string dir + ] + + RelativeSrcDir dir -> + BE.sequence + [ BE.unsignedInt8 1 + , BE.string dir + ] + + +srcDirDecoder : BD.Decoder SrcDir +srcDirDecoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.map AbsoluteSrcDir BD.string + + 1 -> + BD.map RelativeSrcDir BD.string + + _ -> + BD.fail + ) diff --git a/src/Builder/File.elm b/src/Builder/File.elm new file mode 100644 index 0000000000..9e666654d0 --- /dev/null +++ b/src/Builder/File.elm @@ -0,0 +1,197 @@ +module Builder.File exposing + ( Time(..) + , exists + , getTime + , readBinary + , readStdin + , readUtf8 + , remove + , timeDecoder + , timeEncoder + , writeBinary + , writePackage + , writeUtf8 + , zeroTime + ) + +import Codec.Archive.Zip as Zip +import System.IO as IO +import Task exposing (Task) +import Time +import Utils.Bytes.Decode as BD +import Utils.Bytes.Encode as BE +import Utils.Impure as Impure +import Utils.Main as Utils exposing (FilePath) +import Utils.Task.Extra as Task + + + +-- TIME + + +type Time + = Time Time.Posix + + +getTime : FilePath -> Task Never Time +getTime path = + Task.fmap Time (Utils.dirGetModificationTime path) + + +zeroTime : Time +zeroTime = + Time (Time.millisToPosix 0) + + + +-- BINARY + + +writeBinary : (a -> BE.Encoder) -> FilePath -> a -> Task Never () +writeBinary toEncoder path value = + let + dir : FilePath + dir = + Utils.fpDropFileName path + in + Utils.dirCreateDirectoryIfMissing True dir + |> Task.bind (\_ -> Utils.binaryEncodeFile toEncoder path value) + + +readBinary : BD.Decoder a -> FilePath -> Task Never (Maybe a) +readBinary decoder path = + Utils.dirDoesFileExist path + |> Task.bind + (\pathExists -> + if pathExists then + Utils.binaryDecodeFileOrFail decoder path + |> Task.bind + (\result -> + case result of + Ok a -> + Task.pure (Just a) + + Err ( offset, message ) -> + IO.hPutStrLn IO.stderr + (Utils.unlines + [ "+-------------------------------------------------------------------------------" + , "| Corrupt File: " ++ path + , "| Byte Offset: " ++ String.fromInt offset + , "| Message: " ++ message + , "|" + , "| Please report this to https://github.com/elm/compiler/issues" + , "| Trying to continue anyway." + , "+-------------------------------------------------------------------------------" + ] + ) + |> Task.fmap (\_ -> Nothing) + ) + + else + Task.pure Nothing + ) + + + +-- WRITE UTF-8 + + +writeUtf8 : FilePath -> String -> Task Never () +writeUtf8 = + IO.writeString + + + +-- READ UTF-8 + + +readUtf8 : FilePath -> Task Never String +readUtf8 path = + Impure.task "read" [] (Impure.StringBody path) (Impure.StringResolver identity) + + +readStdin : Task Never String +readStdin = + Impure.task "readStdin" [] Impure.EmptyBody (Impure.StringResolver identity) + + + +-- WRITE PACKAGE + + +writePackage : FilePath -> Zip.Archive -> Task Never () +writePackage destination archive = + case Zip.zEntries archive of + [] -> + Task.pure () + + entry :: entries -> + let + root : Int + root = + String.length (Zip.eRelativePath entry) + in + Utils.mapM_ (writeEntry destination root) entries + + +writeEntry : FilePath -> Int -> Zip.Entry -> Task Never () +writeEntry destination root entry = + let + path : String + path = + String.dropLeft root (Zip.eRelativePath entry) + in + if + String.startsWith "src/" path + || (path == "LICENSE") + || (path == "README.md") + || (path == "elm.json") + then + if not (String.isEmpty path) && String.endsWith "/" path then + Utils.dirCreateDirectoryIfMissing True (Utils.fpCombine destination path) + + else + writeUtf8 (Utils.fpCombine destination path) (Zip.fromEntry entry) + + else + Task.pure () + + + +-- EXISTS + + +exists : FilePath -> Task Never Bool +exists path = + Utils.dirDoesFileExist path + + + +-- REMOVE FILES + + +remove : FilePath -> Task Never () +remove path = + Utils.dirDoesFileExist path + |> Task.bind + (\exists_ -> + if exists_ then + Utils.dirRemoveFile path + + else + Task.pure () + ) + + + +-- ENCODERS and DECODERS + + +timeEncoder : Time -> BE.Encoder +timeEncoder (Time posix) = + BE.int (Time.posixToMillis posix) + + +timeDecoder : BD.Decoder Time +timeDecoder = + BD.map (Time << Time.millisToPosix) BD.int diff --git a/src/Builder/Generate.elm b/src/Builder/Generate.elm new file mode 100644 index 0000000000..b1580657ea --- /dev/null +++ b/src/Builder/Generate.elm @@ -0,0 +1,315 @@ +module Builder.Generate exposing + ( debug + , dev + , prod + , repl + ) + +import Builder.Build as Build +import Builder.Elm.Details as Details +import Builder.Elm.Outline as Outline +import Builder.File as File +import Builder.Reporting.Exit as Exit +import Builder.Stuff as Stuff +import Compiler.AST.Optimized as Opt +import Compiler.Data.Name as N +import Compiler.Data.NonEmptyList as NE +import Compiler.Elm.Compiler.Type.Extract as Extract +import Compiler.Elm.Interface as I +import Compiler.Elm.ModuleName as ModuleName +import Compiler.Elm.Package as Pkg +import Compiler.Generate.JavaScript as JS +import Compiler.Generate.Mode as Mode +import Compiler.Nitpick.Debug as Nitpick +import Data.Map as Dict exposing (Dict) +import System.TypeCheck.IO as TypeCheck +import Task exposing (Task) +import Utils.Bytes.Decode as BD +import Utils.Main as Utils exposing (FilePath, MVar) +import Utils.Task.Extra as Task + + + +-- NOTE: This is used by Make, Repl, and Reactor right now. But it may be +-- desireable to have Repl and Reactor to keep foreign objects in memory +-- to make things a bit faster? +-- GENERATORS + + +debug : Bool -> Int -> FilePath -> Details.Details -> Build.Artifacts -> Task Exit.Generate String +debug withSourceMaps leadingLines root details (Build.Artifacts pkg ifaces roots modules) = + loadObjects root details modules + |> Task.bind + (\loading -> + loadTypes root ifaces modules + |> Task.bind + (\types -> + finalizeObjects loading + |> Task.bind + (\objects -> + let + mode : Mode.Mode + mode = + Mode.Dev (Just types) + + graph : Opt.GlobalGraph + graph = + objectsToGlobalGraph objects + + mains : Dict (List String) TypeCheck.Canonical Opt.Main + mains = + gatherMains pkg objects roots + in + prepareSourceMaps withSourceMaps root + |> Task.fmap (\sourceMaps -> JS.generate sourceMaps leadingLines mode graph mains) + ) + ) + ) + + +dev : Bool -> Int -> FilePath -> Details.Details -> Build.Artifacts -> Task Exit.Generate String +dev withSourceMaps leadingLines root details (Build.Artifacts pkg _ roots modules) = + Task.bind finalizeObjects (loadObjects root details modules) + |> Task.bind + (\objects -> + let + mode : Mode.Mode + mode = + Mode.Dev Nothing + + graph : Opt.GlobalGraph + graph = + objectsToGlobalGraph objects + + mains : Dict (List String) TypeCheck.Canonical Opt.Main + mains = + gatherMains pkg objects roots + in + prepareSourceMaps withSourceMaps root + |> Task.fmap (\sourceMaps -> JS.generate sourceMaps leadingLines mode graph mains) + ) + + +prod : Bool -> Int -> FilePath -> Details.Details -> Build.Artifacts -> Task Exit.Generate String +prod withSourceMaps leadingLines root details (Build.Artifacts pkg _ roots modules) = + Task.bind finalizeObjects (loadObjects root details modules) + |> Task.bind + (\objects -> + checkForDebugUses objects + |> Task.bind + (\_ -> + let + graph : Opt.GlobalGraph + graph = + objectsToGlobalGraph objects + + mode : Mode.Mode + mode = + Mode.Prod (Mode.shortenFieldNames graph) + + mains : Dict (List String) TypeCheck.Canonical Opt.Main + mains = + gatherMains pkg objects roots + in + prepareSourceMaps withSourceMaps root + |> Task.fmap (\sourceMaps -> JS.generate sourceMaps leadingLines mode graph mains) + ) + ) + + +prepareSourceMaps : Bool -> FilePath -> Task Exit.Generate JS.SourceMaps +prepareSourceMaps withSourceMaps root = + if withSourceMaps then + Outline.getAllModulePaths root + |> Task.bind (Utils.mapTraverse ModuleName.toComparableCanonical ModuleName.compareCanonical File.readUtf8) + |> Task.fmap JS.SourceMaps + |> Task.io + + else + Task.pure JS.NoSourceMaps + + +repl : FilePath -> Details.Details -> Bool -> Build.ReplArtifacts -> N.Name -> Task Exit.Generate String +repl root details ansi (Build.ReplArtifacts home modules localizer annotations) name = + Task.bind finalizeObjects (loadObjects root details modules) + |> Task.fmap + (\objects -> + let + graph : Opt.GlobalGraph + graph = + objectsToGlobalGraph objects + in + JS.generateForRepl ansi localizer graph home name (Utils.find identity name annotations) + ) + + + +-- CHECK FOR DEBUG + + +checkForDebugUses : Objects -> Task Exit.Generate () +checkForDebugUses (Objects _ locals) = + case Dict.keys compare (Dict.filter (\_ -> Nitpick.hasDebugUses) locals) of + [] -> + Task.pure () + + m :: ms -> + Task.throw (Exit.GenerateCannotOptimizeDebugValues m ms) + + + +-- GATHER MAINS + + +gatherMains : Pkg.Name -> Objects -> NE.Nonempty Build.Root -> Dict (List String) TypeCheck.Canonical Opt.Main +gatherMains pkg (Objects _ locals) roots = + Dict.fromList ModuleName.toComparableCanonical (List.filterMap (lookupMain pkg locals) (NE.toList roots)) + + +lookupMain : Pkg.Name -> Dict String ModuleName.Raw Opt.LocalGraph -> Build.Root -> Maybe ( TypeCheck.Canonical, Opt.Main ) +lookupMain pkg locals root = + let + toPair : N.Name -> Opt.LocalGraph -> Maybe ( TypeCheck.Canonical, Opt.Main ) + toPair name (Opt.LocalGraph maybeMain _ _) = + Maybe.map (Tuple.pair (TypeCheck.Canonical pkg name)) maybeMain + in + case root of + Build.Inside name -> + Maybe.andThen (toPair name) (Dict.get identity name locals) + + Build.Outside name _ g -> + toPair name g + + + +-- LOADING OBJECTS + + +type LoadingObjects + = LoadingObjects (MVar (Maybe Opt.GlobalGraph)) (Dict String ModuleName.Raw (MVar (Maybe Opt.LocalGraph))) + + +loadObjects : FilePath -> Details.Details -> List Build.Module -> Task Exit.Generate LoadingObjects +loadObjects root details modules = + Task.io + (Details.loadObjects root details + |> Task.bind + (\mvar -> + Utils.listTraverse (loadObject root) modules + |> Task.fmap + (\mvars -> + LoadingObjects mvar (Dict.fromList identity mvars) + ) + ) + ) + + +loadObject : FilePath -> Build.Module -> Task Never ( ModuleName.Raw, MVar (Maybe Opt.LocalGraph) ) +loadObject root modul = + case modul of + Build.Fresh name _ graph -> + Utils.newMVar (Utils.maybeEncoder Opt.localGraphEncoder) (Just graph) + |> Task.fmap (\mvar -> ( name, mvar )) + + Build.Cached name _ _ -> + Utils.newEmptyMVar + |> Task.bind + (\mvar -> + Utils.forkIO (Task.bind (Utils.putMVar (Utils.maybeEncoder Opt.localGraphEncoder) mvar) (File.readBinary Opt.localGraphDecoder (Stuff.guidao root name))) + |> Task.fmap (\_ -> ( name, mvar )) + ) + + + +-- FINALIZE OBJECTS + + +type Objects + = Objects Opt.GlobalGraph (Dict String ModuleName.Raw Opt.LocalGraph) + + +finalizeObjects : LoadingObjects -> Task Exit.Generate Objects +finalizeObjects (LoadingObjects mvar mvars) = + Task.eio identity + (Utils.readMVar (BD.maybe Opt.globalGraphDecoder) mvar + |> Task.bind + (\result -> + Utils.mapTraverse identity compare (Utils.readMVar (BD.maybe Opt.localGraphDecoder)) mvars + |> Task.fmap + (\results -> + case Maybe.map2 Objects result (Utils.sequenceDictMaybe identity compare results) of + Just loaded -> + Ok loaded + + Nothing -> + Err Exit.GenerateCannotLoadArtifacts + ) + ) + ) + + +objectsToGlobalGraph : Objects -> Opt.GlobalGraph +objectsToGlobalGraph (Objects globals locals) = + Dict.foldr compare (\_ -> Opt.addLocalGraph) globals locals + + + +-- LOAD TYPES + + +loadTypes : FilePath -> Dict (List String) TypeCheck.Canonical I.DependencyInterface -> List Build.Module -> Task Exit.Generate Extract.Types +loadTypes root ifaces modules = + Task.eio identity + (Utils.listTraverse (loadTypesHelp root) modules + |> Task.bind + (\mvars -> + let + foreigns : Extract.Types + foreigns = + Extract.mergeMany (Dict.values ModuleName.compareCanonical (Dict.map Extract.fromDependencyInterface ifaces)) + in + Utils.listTraverse (Utils.readMVar (BD.maybe Extract.typesDecoder)) mvars + |> Task.fmap + (\results -> + case Utils.sequenceListMaybe results of + Just ts -> + Ok (Extract.merge foreigns (Extract.mergeMany ts)) + + Nothing -> + Err Exit.GenerateCannotLoadArtifacts + ) + ) + ) + + +loadTypesHelp : FilePath -> Build.Module -> Task Never (MVar (Maybe Extract.Types)) +loadTypesHelp root modul = + case modul of + Build.Fresh name iface _ -> + Utils.newMVar (Utils.maybeEncoder Extract.typesEncoder) (Just (Extract.fromInterface name iface)) + + Build.Cached name _ ciMVar -> + Utils.readMVar Build.cachedInterfaceDecoder ciMVar + |> Task.bind + (\cachedInterface -> + case cachedInterface of + Build.Unneeded -> + Utils.newEmptyMVar + |> Task.bind + (\mvar -> + Utils.forkIO + (File.readBinary I.interfaceDecoder (Stuff.guidai root name) + |> Task.bind + (\maybeIface -> + Utils.putMVar (Utils.maybeEncoder Extract.typesEncoder) mvar (Maybe.map (Extract.fromInterface name) maybeIface) + ) + ) + |> Task.fmap (\_ -> mvar) + ) + + Build.Loaded iface -> + Utils.newMVar (Utils.maybeEncoder Extract.typesEncoder) (Just (Extract.fromInterface name iface)) + + Build.Corrupted -> + Utils.newMVar (Utils.maybeEncoder Extract.typesEncoder) Nothing + ) diff --git a/src/Builder/Http.elm b/src/Builder/Http.elm new file mode 100644 index 0000000000..518ac7a7f7 --- /dev/null +++ b/src/Builder/Http.elm @@ -0,0 +1,302 @@ +module Builder.Http exposing + ( Error(..) + , Header + , Manager + , MultiPart + , Sha + , accept + , errorDecoder + , errorEncoder + , filePart + , get + , getArchive + , getManager + , jsonPart + , managerDecoder + , managerEncoder + , post + , shaToChars + , stringPart + , toUrl + , upload + ) + +import Basics.Extra exposing (uncurry) +import Codec.Archive.Zip as Zip +import Compiler.Elm.Version as V +import Http +import Json.Decode as Decode +import Json.Encode as Encode +import Task exposing (Task) +import Url.Builder +import Utils.Bytes.Decode as BD +import Utils.Bytes.Encode as BE +import Utils.Impure as Impure +import Utils.Main as Utils exposing (SomeException) +import Utils.Task.Extra as Task + + + +-- MANAGER + + +type Manager + = Manager + + +managerEncoder : Manager -> BE.Encoder +managerEncoder _ = + BE.unsignedInt8 0 + + +managerDecoder : BD.Decoder Manager +managerDecoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.succeed Manager + + _ -> + BD.fail + ) + + +getManager : Task Never Manager +getManager = + -- TODO newManager tlsManagerSettings + Task.pure Manager + + + +-- URL + + +toUrl : String -> List ( String, String ) -> String +toUrl url params = + case params of + [] -> + url + + _ :: _ -> + url ++ urlEncodeVars params + + +urlEncodeVars : List ( String, String ) -> String +urlEncodeVars params = + -- includes the `?` + Url.Builder.toQuery (List.map (uncurry Url.Builder.string) params) + + + +-- FETCH + + +type alias Header = + ( String, String ) + + +get : Manager -> String -> List Header -> (Error -> e) -> (String -> Task Never (Result e a)) -> Task Never (Result e a) +get = + fetch "GET" + + +post : Manager -> String -> List Header -> (Error -> e) -> (String -> Task Never (Result e a)) -> Task Never (Result e a) +post = + fetch "POST" + + +fetch : String -> Manager -> String -> List Header -> (Error -> e) -> (String -> Task Never (Result e a)) -> Task Never (Result e a) +fetch method _ url headers _ onSuccess = + Impure.customTask method + url + (List.map (\( a, b ) -> Http.header a b) (addDefaultHeaders headers)) + Impure.EmptyBody + (Impure.StringResolver identity) + |> Task.andThen onSuccess + + +addDefaultHeaders : List Header -> List Header +addDefaultHeaders headers = + ( "User-Agent", userAgent ) :: ( "Accept-Encoding", "gzip" ) :: headers + + +userAgent : String +userAgent = + "elm/" ++ V.toChars V.compiler + + +accept : String -> Header +accept mime = + ( "Accept", mime ) + + + +-- EXCEPTIONS + + +type Error + = BadUrl String String + | BadHttp String Utils.HttpExceptionContent + | BadMystery String SomeException + + + +-- SHA + + +type alias Sha = + String + + +shaToChars : Sha -> String +shaToChars = + identity + + + +-- FETCH ARCHIVE + + +getArchive : Manager -> String -> (Error -> e) -> e -> (( Sha, Zip.Archive ) -> Task Never (Result e a)) -> Task Never (Result e a) +getArchive _ url _ _ onSuccess = + Impure.task "getArchive" + [] + (Impure.StringBody url) + (Impure.DecoderResolver + (Decode.map2 Tuple.pair + (Decode.field "sha" Decode.string) + (Decode.field "archive" + (Decode.list + (Decode.map2 Zip.Entry + (Decode.field "eRelativePath" Decode.string) + (Decode.field "eData" Decode.string) + ) + ) + ) + ) + ) + |> Task.andThen onSuccess + + + +-- UPLOAD + + +type MultiPart + = FilePart String String + | JsonPart String String Encode.Value + | StringPart String String + + +upload : Manager -> String -> List MultiPart -> Task Never (Result Error ()) +upload _ url parts = + Impure.task "httpUpload" + [] + (Impure.JsonBody + (Encode.object + [ ( "urlStr", Encode.string url ) + , ( "headers", Encode.object (List.map (Tuple.mapSecond Encode.string) (addDefaultHeaders [])) ) + , ( "parts" + , Encode.list + (\part -> + case part of + FilePart name filePath -> + Encode.object + [ ( "type", Encode.string "FilePart" ) + , ( "name", Encode.string name ) + , ( "filePath", Encode.string filePath ) + ] + + JsonPart name filePath value -> + Encode.object + [ ( "type", Encode.string "JsonPart" ) + , ( "name", Encode.string name ) + , ( "filePath", Encode.string filePath ) + , ( "value", value ) + ] + + StringPart name string -> + Encode.object + [ ( "type", Encode.string "StringPart" ) + , ( "name", Encode.string name ) + , ( "string", Encode.string string ) + ] + ) + parts + ) + ] + ) + ) + (Impure.Always (Ok ())) + + +filePart : String -> String -> MultiPart +filePart name filePath = + FilePart name filePath + + +jsonPart : String -> String -> Encode.Value -> MultiPart +jsonPart name filePath value = + JsonPart name filePath value + + +stringPart : String -> String -> MultiPart +stringPart name string = + StringPart name string + + + +-- ENCODERS and DECODERS + + +errorEncoder : Error -> BE.Encoder +errorEncoder error = + case error of + BadUrl url reason -> + BE.sequence + [ BE.unsignedInt8 0 + , BE.string url + , BE.string reason + ] + + BadHttp url httpExceptionContent -> + BE.sequence + [ BE.unsignedInt8 1 + , BE.string url + , Utils.httpExceptionContentEncoder httpExceptionContent + ] + + BadMystery url someException -> + BE.sequence + [ BE.unsignedInt8 2 + , BE.string url + , Utils.someExceptionEncoder someException + ] + + +errorDecoder : BD.Decoder Error +errorDecoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.map2 BadUrl + BD.string + BD.string + + 1 -> + BD.map2 BadHttp + BD.string + Utils.httpExceptionContentDecoder + + 2 -> + BD.map2 BadMystery + BD.string + Utils.someExceptionDecoder + + _ -> + BD.fail + ) diff --git a/src/Builder/Reporting.elm b/src/Builder/Reporting.elm new file mode 100644 index 0000000000..e77b40ccae --- /dev/null +++ b/src/Builder/Reporting.elm @@ -0,0 +1,672 @@ +module Builder.Reporting exposing + ( BKey + , BMsg(..) + , DKey + , DMsg(..) + , Key + , Style + , ask + , attempt + , attemptWithStyle + , ignorer + , json + , report + , reportGenerate + , silent + , terminal + , trackBuild + , trackDetails + ) + +import Builder.Reporting.Exit as Exit +import Builder.Reporting.Exit.Help as Help +import Compiler.Data.NonEmptyList as NE +import Compiler.Elm.ModuleName as ModuleName +import Compiler.Elm.Package as Pkg +import Compiler.Elm.Version as V +import Compiler.Json.Encode as Encode +import Compiler.Reporting.Doc as D +import System.Exit as Exit +import System.IO as IO +import Task exposing (Task) +import Utils.Bytes.Decode as BD +import Utils.Bytes.Encode as BE +import Utils.Main as Utils exposing (Chan, MVar) +import Utils.Task.Extra as Task + + + +-- STYLE + + +type Style + = Silent + | Json + | Terminal (MVar ()) + + +silent : Style +silent = + Silent + + +json : Style +json = + Json + + +terminal : Task Never Style +terminal = + Task.fmap Terminal (Utils.newMVar (\_ -> BE.bool True) ()) + + + +-- ATTEMPT + + +attempt : (x -> Help.Report) -> Task Never (Result x a) -> Task Never a +attempt toReport work = + work + -- |> IO.catch reportExceptionsNicely + |> Task.bind + (\result -> + case result of + Ok a -> + Task.pure a + + Err x -> + Exit.toStderr (toReport x) + |> Task.bind (\_ -> Exit.exitFailure) + ) + + +attemptWithStyle : Style -> (x -> Help.Report) -> Task Never (Result x a) -> Task Never a +attemptWithStyle style toReport work = + work + -- |> IO.catch reportExceptionsNicely + |> Task.bind + (\result -> + case result of + Ok a -> + Task.pure a + + Err x -> + case style of + Silent -> + Exit.exitFailure + + Json -> + Utils.builderHPutBuilder IO.stderr (Encode.encodeUgly (Exit.toJson (toReport x))) + |> Task.bind (\_ -> Exit.exitFailure) + + Terminal mvar -> + Utils.readMVar (BD.map (\_ -> ()) BD.bool) mvar + |> Task.bind (\_ -> Exit.toStderr (toReport x)) + |> Task.bind (\_ -> Exit.exitFailure) + ) + + + +-- MARKS + + +goodMark : D.Doc +goodMark = + D.green + (if isWindows then + D.fromChars "+" + + else + D.fromChars "●" + ) + + +badMark : D.Doc +badMark = + D.red + (if isWindows then + D.fromChars "X" + + else + D.fromChars "✗" + ) + + +isWindows : Bool +isWindows = + -- TODO Info.os == "mingw32" + False + + + +-- KEY + + +type Key msg + = Key (msg -> Task Never ()) + + +report : Key msg -> msg -> Task Never () +report (Key send) msg = + send msg + + +ignorer : Key msg +ignorer = + Key (\_ -> Task.pure ()) + + + +-- ASK + + +ask : D.Doc -> Task Never Bool +ask doc = + Help.toStdout doc + |> Task.bind (\_ -> askHelp) + + +askHelp : Task Never Bool +askHelp = + IO.hFlush IO.stdout + |> Task.bind (\_ -> IO.getLine) + |> Task.bind + (\input -> + case input of + "" -> + Task.pure True + + "Y" -> + Task.pure True + + "y" -> + Task.pure True + + "n" -> + Task.pure False + + _ -> + IO.putStr "Must type 'y' for yes or 'n' for no: " + |> Task.bind (\_ -> askHelp) + ) + + + +-- DETAILS + + +type alias DKey = + Key DMsg + + +trackDetails : Style -> (DKey -> Task Never a) -> Task Never a +trackDetails style callback = + case style of + Silent -> + callback (Key (\_ -> Task.pure ())) + + Json -> + callback (Key (\_ -> Task.pure ())) + + Terminal mvar -> + Utils.newChan Utils.mVarEncoder + |> Task.bind + (\chan -> + Utils.forkIO + (Utils.takeMVar (BD.succeed ()) mvar + |> Task.bind (\_ -> detailsLoop chan (DState 0 0 0 0 0 0 0)) + |> Task.bind (\_ -> Utils.putMVar (\_ -> BE.bool True) mvar ()) + ) + |> Task.bind + (\_ -> + let + encoder : Maybe DMsg -> BE.Encoder + encoder = + BE.maybe dMsgEncoder + in + callback (Key (Utils.writeChan encoder chan << Just)) + |> Task.bind + (\answer -> + Utils.writeChan encoder chan Nothing + |> Task.fmap (\_ -> answer) + ) + ) + ) + + +detailsLoop : Chan (Maybe DMsg) -> DState -> Task Never () +detailsLoop chan ((DState total _ _ _ _ built _) as state) = + Utils.readChan (BD.maybe dMsgDecoder) chan + |> Task.bind + (\msg -> + case msg of + Just dmsg -> + Task.bind (detailsLoop chan) (detailsStep dmsg state) + + Nothing -> + IO.putStrLn + (clear (toBuildProgress total total) + (if built == total then + "Dependencies ready!" + + else + "Dependency problem!" + ) + ) + ) + + +type DState + = DState Int Int Int Int Int Int Int + + +type DMsg + = DStart Int + | DCached + | DRequested + | DReceived Pkg.Name V.Version + | DFailed Pkg.Name V.Version + | DBuilt + | DBroken + + +detailsStep : DMsg -> DState -> Task Never DState +detailsStep msg (DState total cached rqst rcvd failed built broken) = + case msg of + DStart numDependencies -> + Task.pure (DState numDependencies 0 0 0 0 0 0) + + DCached -> + putTransition (DState total (cached + 1) rqst rcvd failed built broken) + + DRequested -> + (if rqst == 0 then + IO.putStrLn "Starting downloads...\n" + + else + Task.pure () + ) + |> Task.fmap (\_ -> DState total cached (rqst + 1) rcvd failed built broken) + + DReceived pkg vsn -> + putDownload goodMark pkg vsn + |> Task.bind (\_ -> putTransition (DState total cached rqst (rcvd + 1) failed built broken)) + + DFailed pkg vsn -> + putDownload badMark pkg vsn + |> Task.bind (\_ -> putTransition (DState total cached rqst rcvd (failed + 1) built broken)) + + DBuilt -> + putBuilt (DState total cached rqst rcvd failed (built + 1) broken) + + DBroken -> + putBuilt (DState total cached rqst rcvd failed built (broken + 1)) + + +putDownload : D.Doc -> Pkg.Name -> V.Version -> Task Never () +putDownload mark pkg vsn = + Help.toStdout + (D.indent 2 + (mark + |> D.plus (D.fromPackage pkg) + |> D.plus (D.fromVersion vsn) + |> D.a (D.fromChars "\n") + ) + ) + + +putTransition : DState -> Task Never DState +putTransition ((DState total cached _ rcvd failed built broken) as state) = + if cached + rcvd + failed < total then + Task.pure state + + else + let + char : Char + char = + if rcvd + failed == 0 then + '\u{000D}' + + else + '\n' + in + putStrFlush (String.cons char (toBuildProgress (built + broken + failed) total)) + |> Task.fmap (\_ -> state) + + +putBuilt : DState -> Task Never DState +putBuilt ((DState total cached _ rcvd failed built broken) as state) = + (if total == cached + rcvd + failed then + putStrFlush (String.cons '\u{000D}' (toBuildProgress (built + broken + failed) total)) + + else + Task.pure () + ) + |> Task.fmap (\_ -> state) + + +toBuildProgress : Int -> Int -> String +toBuildProgress built total = + "Verifying dependencies (" ++ String.fromInt built ++ "/" ++ String.fromInt total ++ ")" + + +clear : String -> String -> String +clear before after = + String.cons '\u{000D}' + (String.repeat (String.length before) " " + ++ String.cons '\u{000D}' after + ) + + + +-- BUILD + + +type alias BKey = + Key BMsg + + +type alias BResult a = + Result Exit.BuildProblem a + + +trackBuild : BD.Decoder a -> (a -> BE.Encoder) -> Style -> (BKey -> Task Never (BResult a)) -> Task Never (BResult a) +trackBuild decoder encoder style callback = + case style of + Silent -> + callback (Key (\_ -> Task.pure ())) + + Json -> + callback (Key (\_ -> Task.pure ())) + + Terminal mvar -> + Utils.newChan Utils.mVarEncoder + |> Task.bind + (\chan -> + let + chanEncoder : Result BMsg (BResult a) -> BE.Encoder + chanEncoder = + BE.result bMsgEncoder (bResultEncoder encoder) + in + Utils.forkIO + (Utils.takeMVar (BD.succeed ()) mvar + |> Task.bind (\_ -> putStrFlush "Compiling ...") + |> Task.bind (\_ -> buildLoop decoder chan 0) + |> Task.bind (\_ -> Utils.putMVar (\_ -> BE.bool True) mvar ()) + ) + |> Task.bind (\_ -> callback (Key (Utils.writeChan chanEncoder chan << Err))) + |> Task.bind + (\result -> + Utils.writeChan chanEncoder chan (Ok result) + |> Task.fmap (\_ -> result) + ) + ) + + +type BMsg + = BDone + + +buildLoop : BD.Decoder a -> Chan (Result BMsg (BResult a)) -> Int -> Task Never () +buildLoop decoder chan done = + Utils.readChan (BD.result bMsgDecoder (bResultDecoder decoder)) chan + |> Task.bind + (\msg -> + case msg of + Err BDone -> + let + done1 : Int + done1 = + done + 1 + in + putStrFlush ("\u{000D}Compiling (" ++ String.fromInt done1 ++ ")") + |> Task.bind (\_ -> buildLoop decoder chan done1) + + Ok result -> + let + message : String + message = + toFinalMessage done result + + width : Int + width = + 12 + String.length (String.fromInt done) + in + IO.putStrLn + (if String.length message < width then + String.cons '\u{000D}' (String.repeat width " ") + ++ String.cons '\u{000D}' message + + else + String.cons '\u{000D}' message + ) + ) + + +toFinalMessage : Int -> BResult a -> String +toFinalMessage done result = + case result of + Ok _ -> + case done of + 0 -> + "Success!" + + 1 -> + "Success! Compiled 1 module." + + n -> + "Success! Compiled " ++ String.fromInt n ++ " modules." + + Err problem -> + case problem of + Exit.BuildBadModules _ _ [] -> + "Detected problems in 1 module." + + Exit.BuildBadModules _ _ (_ :: ps) -> + "Detected problems in " ++ String.fromInt (2 + List.length ps) ++ " modules." + + Exit.BuildProjectProblem _ -> + "Detected a problem." + + + +-- GENERATE + + +reportGenerate : Style -> NE.Nonempty ModuleName.Raw -> String -> Task Never () +reportGenerate style names output = + case style of + Silent -> + Task.pure () + + Json -> + Task.pure () + + Terminal mvar -> + Utils.readMVar (BD.map (\_ -> ()) BD.bool) mvar + |> Task.bind + (\_ -> + let + cnames : NE.Nonempty String + cnames = + NE.map (ModuleName.toChars >> String.fromList) names + in + IO.putStrLn (String.cons '\n' (toGenDiagram cnames output)) + ) + + +toGenDiagram : NE.Nonempty String -> String -> String +toGenDiagram (NE.Nonempty name names) output = + let + width : Int + width = + 3 + List.foldr (max << String.length) (String.length name) names + in + case names of + [] -> + toGenLine width name (String.cons '>' (String.cons ' ' output ++ "\n")) + + _ :: _ -> + Utils.unlines + (toGenLine width name (String.cons vtop (String.cons hbar (String.cons hbar (String.cons '>' (String.cons ' ' output))))) + :: List.reverse (List.map2 (toGenLine width) (List.reverse names) (String.fromChar vbottom :: List.repeat (List.length names - 1) (String.fromChar vmiddle))) + ) + + +toGenLine : Int -> String -> String -> String +toGenLine width name end = + " " + ++ name + ++ String.cons ' ' (String.repeat (width - String.length name) (String.fromChar hbar)) + ++ end + + +hbar : Char +hbar = + if isWindows then + '-' + + else + '─' + + +vtop : Char +vtop = + if isWindows then + '+' + + else + '┬' + + +vmiddle : Char +vmiddle = + if isWindows then + '+' + + else + '┤' + + +vbottom : Char +vbottom = + if isWindows then + '+' + + else + '┘' + + + +-- + + +putStrFlush : String -> Task Never () +putStrFlush str = + IO.hPutStr IO.stdout str + |> Task.bind (\_ -> IO.hFlush IO.stdout) + + + +-- ENCODERS and DECODERS + + +dMsgEncoder : DMsg -> BE.Encoder +dMsgEncoder dMsg = + case dMsg of + DStart numDependencies -> + BE.sequence + [ BE.unsignedInt8 0 + , BE.int numDependencies + ] + + DCached -> + BE.unsignedInt8 1 + + DRequested -> + BE.unsignedInt8 2 + + DReceived pkg vsn -> + BE.sequence + [ BE.unsignedInt8 3 + , Pkg.nameEncoder pkg + , V.versionEncoder vsn + ] + + DFailed pkg vsn -> + BE.sequence + [ BE.unsignedInt8 4 + , Pkg.nameEncoder pkg + , V.versionEncoder vsn + ] + + DBuilt -> + BE.unsignedInt8 5 + + DBroken -> + BE.unsignedInt8 6 + + +dMsgDecoder : BD.Decoder DMsg +dMsgDecoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.map DStart BD.int + + 1 -> + BD.succeed DCached + + 2 -> + BD.succeed DRequested + + 3 -> + BD.map2 DReceived + Pkg.nameDecoder + V.versionDecoder + + 4 -> + BD.map2 DFailed + Pkg.nameDecoder + V.versionDecoder + + 5 -> + BD.succeed DBuilt + + 6 -> + BD.succeed DBroken + + _ -> + BD.fail + ) + + +bMsgEncoder : BMsg -> BE.Encoder +bMsgEncoder _ = + BE.unsignedInt8 0 + + +bMsgDecoder : BD.Decoder BMsg +bMsgDecoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.succeed BDone + + _ -> + BD.fail + ) + + +bResultEncoder : (a -> BE.Encoder) -> BResult a -> BE.Encoder +bResultEncoder encoder bResult = + BE.result Exit.buildProblemEncoder encoder bResult + + +bResultDecoder : BD.Decoder a -> BD.Decoder (BResult a) +bResultDecoder decoder = + BD.result Exit.buildProblemDecoder decoder diff --git a/src/Builder/Reporting/Exit.elm b/src/Builder/Reporting/Exit.elm new file mode 100644 index 0000000000..cdefd78374 --- /dev/null +++ b/src/Builder/Reporting/Exit.elm @@ -0,0 +1,3337 @@ +module Builder.Reporting.Exit exposing + ( BuildProblem(..) + , BuildProjectProblem(..) + , Bump(..) + , Details(..) + , DetailsBadDep(..) + , Diff(..) + , DocsProblem(..) + , Generate(..) + , Init(..) + , Install(..) + , Make(..) + , Outline(..) + , OutlineProblem(..) + , PackageProblem(..) + , Publish(..) + , RegistryProblem(..) + , Repl(..) + , Solver(..) + , Test(..) + , Uninstall(..) + , buildProblemDecoder + , buildProblemEncoder + , buildProjectProblemDecoder + , buildProjectProblemEncoder + , bumpToReport + , detailsBadDepDecoder + , detailsBadDepEncoder + , diffToReport + , initToReport + , installToReport + , makeToReport + , newPackageOverview + , publishToReport + , registryProblemDecoder + , registryProblemEncoder + , replToReport + , testToReport + , toJson + , toStderr + , uninstallToReport + ) + +import Builder.File as File +import Builder.Http as Http +import Builder.Reporting.Exit.Help as Help +import Compiler.Data.Name as N +import Compiler.Data.NonEmptyList as NE +import Compiler.Elm.Constraint as C +import Compiler.Elm.Magnitude as M +import Compiler.Elm.ModuleName as ModuleName +import Compiler.Elm.Package as Pkg +import Compiler.Elm.Version as V +import Compiler.Json.Decode as Decode +import Compiler.Json.Encode as Encode +import Compiler.Parse.Primitives exposing (Col, Row) +import Compiler.Reporting.Annotation as A +import Compiler.Reporting.Doc as D +import Compiler.Reporting.Error as Error +import Compiler.Reporting.Error.Import as Import +import Compiler.Reporting.Error.Json as Json +import Compiler.Reporting.Render.Code as Code +import Data.Map as Dict exposing (Dict) +import Task exposing (Task) +import Utils.Bytes.Decode as BD +import Utils.Bytes.Encode as BE +import Utils.Main as Utils exposing (FilePath) + + + +-- RENDERERS + + +toStderr : Help.Report -> Task Never () +toStderr report = + Help.toStderr (Help.reportToDoc report) + + +toJson : Help.Report -> Encode.Value +toJson report = + Help.reportToJson report + + + +-- INIT + + +type Init + = InitNoSolution (List Pkg.Name) + | InitNoOfflineSolution (List Pkg.Name) + | InitSolverProblem Solver + | InitAlreadyExists + | InitRegistryProblem RegistryProblem + + +initToReport : Init -> Help.Report +initToReport exit = + case exit of + InitNoSolution pkgs -> + Help.report "NO SOLUTION" + Nothing + "I tried to create an elm.json with the following direct dependencies:" + [ D.indent 4 <| + D.vcat <| + List.map (D.dullyellow << D.fromChars << Pkg.toChars) pkgs + , D.reflow "I could not find compatible versions though! This should not happen, so please ask around one of the community forums at https://elm-lang.org/community to learn what is going on!" + ] + + InitNoOfflineSolution pkgs -> + Help.report "NO OFFLINE SOLUTION" + Nothing + "I tried to create an elm.json with the following direct dependencies:" + [ D.indent 4 <| + D.vcat <| + List.map (D.dullyellow << D.fromChars << Pkg.toChars) pkgs + , D.reflow "I could not find compatible versions though, but that may be because I could not connect to https://package.elm-lang.org to get the latest list of packages. Are you able to connect to the internet? Please ask around one of the community forums at https://elm-lang.org/community for help!" + ] + + InitSolverProblem solver -> + toSolverReport solver + + InitAlreadyExists -> + Help.report "EXISTING PROJECT" + Nothing + "You already have an elm.json file, so there is nothing for me to initialize!" + [ D.fillSep + [ D.fromChars "Maybe" + , D.green (D.fromChars (D.makeLink "init")) + , D.fromChars "can" + , D.fromChars "help" + , D.fromChars "you" + , D.fromChars "figure" + , D.fromChars "out" + , D.fromChars "what" + , D.fromChars "to" + , D.fromChars "do" + , D.fromChars "next?" + ] + ] + + InitRegistryProblem problem -> + toRegistryProblemReport "PROBLEM LOADING PACKAGE LIST" problem <| + "I need the list of published packages before I can start initializing projects" + + + +-- DIFF + + +type Diff + = DiffNoOutline + | DiffBadOutline Outline + | DiffApplication + | DiffNoExposed + | DiffUnpublished + | DiffUnknownPackage Pkg.Name (List Pkg.Name) + | DiffUnknownVersion V.Version (List V.Version) + | DiffDocsProblem V.Version DocsProblem + | DiffMustHaveLatestRegistry RegistryProblem + | DiffBadDetails Details + | DiffBadBuild BuildProblem + + +diffToReport : Diff -> Help.Report +diffToReport diff = + case diff of + DiffNoOutline -> + Help.report "DIFF WHAT?" + Nothing + "I cannot find an elm.json so I am not sure what you want me to diff. Normally you run `elm diff` from within a project!" + [ D.reflow <| "If you are just curious to see a diff, try running this command:" + , D.indent 4 <| D.green <| D.fromChars "elm diff elm/http 1.0.0 2.0.0" + ] + + DiffBadOutline outline -> + toOutlineReport outline + + DiffApplication -> + Help.report "CANNOT DIFF APPLICATIONS" + (Just "elm.json") + "Your elm.json says this project is an application, but `elm diff` only works with packages. That way there are previously published versions of the API to diff against!" + [ D.reflow <| "If you are just curious to see a diff, try running this command:" + , D.indent 4 <| D.dullyellow <| D.fromChars "elm diff elm/json 1.0.0 1.1.2" + ] + + DiffNoExposed -> + Help.report "NO EXPOSED MODULES" + (Just "elm.json") + "Your elm.json has no \"exposed-modules\" which means there is no public API at all right now! What am I supposed to diff?" + [ D.reflow <| + "Try adding some modules back to the \"exposed-modules\" field." + ] + + DiffUnpublished -> + Help.report "UNPUBLISHED" + Nothing + "This package is not published yet. There is nothing to diff against!" + [] + + DiffUnknownPackage pkg suggestions -> + Help.report "UNKNOWN PACKAGE" + Nothing + "I cannot find a package called:" + [ D.indent 4 <| D.red <| D.fromChars <| Pkg.toChars pkg + , D.fromChars "Maybe you want one of these instead?" + , D.indent 4 <| D.dullyellow <| D.vcat <| List.map (D.fromChars << Pkg.toChars) suggestions + , D.fromChars "But check to see all possibilities!" + ] + + DiffUnknownVersion vsn realVersions -> + Help.docReport "UNKNOWN VERSION" + Nothing + (D.fillSep <| + [ D.fromChars "Version" + , D.red (D.fromVersion vsn) + , D.fromChars "has" + , D.fromChars "never" + , D.fromChars "been" + , D.fromChars "published," + , D.fromChars "so" + , D.fromChars "I" + , D.fromChars "cannot" + , D.fromChars "diff" + , D.fromChars "against" + , D.fromChars "it." + ] + ) + [ D.fromChars "Here are all the versions that HAVE been published:" + , D.indent 4 <| + D.dullyellow <| + D.vcat <| + let + sameMajor : V.Version -> V.Version -> Bool + sameMajor v1 v2 = + V.major v1 == V.major v2 + + mkRow : List V.Version -> D.Doc + mkRow vsns = + D.hsep <| List.map D.fromVersion vsns + in + List.map mkRow <| Utils.listGroupBy sameMajor (List.sortWith V.compare realVersions) + , D.fromChars "Want one of those instead?" + ] + + DiffDocsProblem version problem -> + toDocsProblemReport problem <| + "I need the docs for " + ++ V.toChars version + ++ " to compute this diff" + + DiffMustHaveLatestRegistry problem -> + toRegistryProblemReport "PROBLEM UPDATING PACKAGE LIST" problem <| + "I need the latest list of published packages before I do this diff" + + DiffBadDetails details -> + toDetailsReport details + + DiffBadBuild buildProblem -> + toBuildProblemReport buildProblem + + + +-- BUMP + + +type Bump + = BumpNoOutline + | BumpBadOutline Outline + | BumpApplication + | BumpUnexpectedVersion V.Version (List V.Version) + | BumpMustHaveLatestRegistry RegistryProblem + | BumpCannotFindDocs V.Version DocsProblem + | BumpBadDetails Details + | BumpNoExposed + | BumpBadBuild BuildProblem + + +bumpToReport : Bump -> Help.Report +bumpToReport bump = + case bump of + BumpNoOutline -> + Help.report "BUMP WHAT?" + Nothing + "I cannot find an elm.json so I am not sure what you want me to bump." + [ D.reflow <| + "Elm packages always have an elm.json that says the current version number. If you run this command from a directory with an elm.json file, I will try to bump the version in there based on the API changes." + ] + + BumpBadOutline outline -> + toOutlineReport outline + + BumpApplication -> + Help.report "CANNOT BUMP APPLICATIONS" + (Just "elm.json") + "Your elm.json says this is an application. That means it cannot be published on and therefore has no version to bump!" + [] + + BumpUnexpectedVersion vsn versions -> + Help.docReport "CANNOT BUMP" + (Just "elm.json") + (D.fillSep + [ D.fromChars "Your" + , D.fromChars "elm.json" + , D.fromChars "says" + , D.fromChars "I" + , D.fromChars "should" + , D.fromChars "bump" + , D.fromChars "relative" + , D.fromChars "to" + , D.fromChars "version" + , D.red (D.fromVersion vsn) + |> D.a (D.fromChars ",") + , D.fromChars "but" + , D.fromChars "I" + , D.fromChars "cannot" + , D.fromChars "find" + , D.fromChars "that" + , D.fromChars "version" + , D.fromChars "on" + , D.fromChars "." + , D.fromChars "That" + , D.fromChars "means" + , D.fromChars "there" + , D.fromChars "is" + , D.fromChars "no" + , D.fromChars "API" + , D.fromChars "for" + , D.fromChars "me" + , D.fromChars "to" + , D.fromChars "diff" + , D.fromChars "against" + , D.fromChars "and" + , D.fromChars "figure" + , D.fromChars "out" + , D.fromChars "if" + , D.fromChars "these" + , D.fromChars "are" + , D.fromChars "MAJOR," + , D.fromChars "MINOR," + , D.fromChars "or" + , D.fromChars "PATCH" + , D.fromChars "changes." + ] + ) + [ D.fillSep <| + [ D.fromChars "Try" + , D.fromChars "bumping" + , D.fromChars "again" + , D.fromChars "after" + , D.fromChars "changing" + , D.fromChars "the" + , D.dullyellow (D.fromChars "\"version\"") + , D.fromChars "in" + , D.fromChars "elm.json" + ] + ++ (if List.length versions == 1 then + [ D.fromChars "to:" ] + + else + [ D.fromChars "to" + , D.fromChars "one" + , D.fromChars "of" + , D.fromChars "these:" + ] + ) + , D.vcat <| List.map (D.green << D.fromVersion) versions + ] + + BumpMustHaveLatestRegistry problem -> + toRegistryProblemReport "PROBLEM UPDATING PACKAGE LIST" problem <| + "I need the latest list of published packages before I can bump any versions" + + BumpCannotFindDocs version problem -> + toDocsProblemReport problem <| + "I need the docs for " + ++ V.toChars version + ++ " to compute the next version number" + + BumpBadDetails details -> + toDetailsReport details + + BumpNoExposed -> + Help.docReport "NO EXPOSED MODULES" + (Just "elm.json") + (D.fillSep <| + [ D.fromChars "To" + , D.fromChars "bump" + , D.fromChars "a" + , D.fromChars "package," + , D.fromChars "the" + , D.dullyellow (D.fromChars "\"exposed-modules\"") + , D.fromChars "field" + , D.fromChars "of" + , D.fromChars "your" + , D.fromChars "elm.json" + , D.fromChars "must" + , D.fromChars "list" + , D.fromChars "at" + , D.fromChars "least" + , D.fromChars "one" + , D.fromChars "module." + ] + ) + [ D.reflow <| + "Try adding some modules back to the \"exposed-modules\" field." + ] + + BumpBadBuild problem -> + toBuildProblemReport problem + + + +-- OVERVIEW OF VERSIONING + + +newPackageOverview : String +newPackageOverview = + Utils.unlines + [ "This package has never been published before. Here's how things work:" + , "" + , " - Versions all have exactly three parts: MAJOR.MINOR.PATCH" + , "" + , " - All packages start with initial version " ++ V.toChars V.one + , "" + , " - Versions are incremented based on how the API changes:" + , "" + , " PATCH = the API is the same, no risk of breaking code" + , " MINOR = values have been added, existing values are unchanged" + , " MAJOR = existing values have been changed or removed" + , "" + , " - I will bump versions for you, automatically enforcing these rules" + , "" + ] + + + +-- PUBLISH + + +type Publish + = PublishNoOutline + | PublishBadOutline Outline + | PublishBadDetails Details + | PublishMustHaveLatestRegistry RegistryProblem + | PublishApplication + | PublishNotInitialVersion V.Version + | PublishAlreadyPublished V.Version + | PublishInvalidBump V.Version V.Version + | PublishBadBump V.Version V.Version M.Magnitude V.Version M.Magnitude + | PublishNoSummary + | PublishNoExposed + | PublishNoReadme + | PublishShortReadme + | PublishNoLicense + | PublishBuildProblem BuildProblem + | PublishMissingTag V.Version + | PublishCannotGetTag V.Version Http.Error + | PublishCannotGetTagData V.Version String String + | PublishCannotGetZip Http.Error + | PublishCannotDecodeZip String + | PublishCannotGetDocs V.Version V.Version DocsProblem + | PublishCannotRegister Http.Error + | PublishNoGit + | PublishLocalChanges V.Version + -- + | PublishZipBadDetails Details + | PublishZipApplication + | PublishZipNoExposed + | PublishZipBuildProblem BuildProblem + + +publishToReport : Publish -> Help.Report +publishToReport publish = + case publish of + PublishNoOutline -> + Help.report "PUBLISH WHAT?" + Nothing + "I cannot find an elm.json so I am not sure what you want me to publish." + [ D.reflow <| + "Elm packages always have an elm.json that states the version number, dependencies, exposed modules, etc." + ] + + PublishBadOutline outline -> + toOutlineReport outline + + PublishBadDetails problem -> + toDetailsReport problem + + PublishMustHaveLatestRegistry problem -> + toRegistryProblemReport "PROBLEM UPDATING PACKAGE LIST" problem <| + "I need the latest list of published packages to make sure this is safe to publish" + + PublishApplication -> + Help.report "UNPUBLISHABLE" Nothing "I cannot publish applications, only packages!" [] + + PublishNotInitialVersion vsn -> + Help.docReport "INVALID VERSION" + Nothing + (D.fillSep + [ D.fromChars "I" + , D.fromChars "cannot" + , D.fromChars "publish" + , D.red (D.fromVersion vsn) + , D.fromChars "as" + , D.fromChars "the" + , D.fromChars "initial" + , D.fromChars "version." + ] + ) + [ D.fillSep + [ D.fromChars "Change" + , D.fromChars "it" + , D.fromChars "to" + , D.green (D.fromChars "1.0.0") + , D.fromChars "which" + , D.fromChars "is" + , D.fromChars "the" + , D.fromChars "initial" + , D.fromChars "version" + , D.fromChars "for" + , D.fromChars "all" + , D.fromChars "Elm" + , D.fromChars "packages." + ] + ] + + PublishAlreadyPublished vsn -> + Help.docReport "ALREADY PUBLISHED" + Nothing + (D.vcat + [ D.fillSep + [ D.fromChars "Version" + , D.green (D.fromVersion vsn) + , D.fromChars "has" + , D.fromChars "already" + , D.fromChars "been" + , D.fromChars "published." + , D.fromChars "You" + , D.fromChars "cannot" + , D.fromChars "publish" + , D.fromChars "it" + , D.fromChars "again!" + ] + , D.fromChars "Try using the `bump` command:" + ] + ) + [ D.dullyellow <| D.indent 4 (D.fromChars "elm bump") + , D.reflow <| + "It computes the version number based on API changes, ensuring that no breaking changes end up in PATCH releases!" + ] + + PublishInvalidBump statedVersion latestVersion -> + Help.docReport "INVALID VERSION" + (Just "elm.json") + (D.fillSep <| + [ D.fromChars "Your" + , D.fromChars "elm.json" + , D.fromChars "says" + , D.fromChars "the" + , D.fromChars "next" + , D.fromChars "version" + , D.fromChars "should" + , D.fromChars "be" + , D.red (D.fromVersion statedVersion) |> D.a (D.fromChars ",") + , D.fromChars "but" + , D.fromChars "that" + , D.fromChars "is" + , D.fromChars "not" + , D.fromChars "valid" + , D.fromChars "based" + , D.fromChars "on" + , D.fromChars "the" + , D.fromChars "previously" + , D.fromChars "published" + , D.fromChars "versions." + ] + ) + [ D.fillSep <| + [ D.fromChars "Change" + , D.fromChars "the" + , D.fromChars "version" + , D.fromChars "back" + , D.fromChars "to" + , D.green (D.fromVersion latestVersion) + , D.fromChars "which" + , D.fromChars "is" + , D.fromChars "the" + , D.fromChars "most" + , D.fromChars "recently" + , D.fromChars "published" + , D.fromChars "version." + , D.fromChars "From" + , D.fromChars "there," + , D.fromChars "have" + , D.fromChars "Elm" + , D.fromChars "bump" + , D.fromChars "the" + , D.fromChars "version" + , D.fromChars "by" + , D.fromChars "running:" + ] + , D.indent 4 <| D.green (D.fromChars "elm bump") + , D.reflow <| + "If you want more insight on the API changes Elm detects, you can run `elm diff` at this point as well." + ] + + PublishBadBump old new magnitude realNew realMagnitude -> + Help.docReport "INVALID VERSION" + (Just "elm.json") + (D.fillSep <| + [ D.fromChars "Your" + , D.fromChars "elm.json" + , D.fromChars "says" + , D.fromChars "the" + , D.fromChars "next" + , D.fromChars "version" + , D.fromChars "should" + , D.fromChars "be" + , D.red (D.fromVersion new) + |> D.a (D.fromChars ",") + , D.fromChars "indicating" + , D.fromChars "a" + , D.fromChars (M.toChars magnitude) + , D.fromChars "change" + , D.fromChars "to" + , D.fromChars "the" + , D.fromChars "public" + , D.fromChars "API." + , D.fromChars "This" + , D.fromChars "does" + , D.fromChars "not" + , D.fromChars "match" + , D.fromChars "the" + , D.fromChars "API" + , D.fromChars "diff" + , D.fromChars "given" + , D.fromChars "by:" + ] + ) + [ D.indent 4 <| + D.fromChars <| + "elm diff " + ++ V.toChars old + , D.fillSep <| + [ D.fromChars "This" + , D.fromChars "command" + , D.fromChars "says" + , D.fromChars "this" + , D.fromChars "is" + , D.fromChars "a" + , D.fromChars (M.toChars realMagnitude) + , D.fromChars "change," + , D.fromChars "so" + , D.fromChars "the" + , D.fromChars "next" + , D.fromChars "version" + , D.fromChars "should" + , D.fromChars "be" + , D.green (D.fromVersion realNew) |> D.a (D.fromChars ".") + , D.fromChars "Double" + , D.fromChars "check" + , D.fromChars "everything" + , D.fromChars "to" + , D.fromChars "make" + , D.fromChars "sure" + , D.fromChars "you" + , D.fromChars "are" + , D.fromChars "publishing" + , D.fromChars "what" + , D.fromChars "you" + , D.fromChars "want!" + ] + , D.reflow <| + "Also, next time use `elm bump` and I'll figure all this out for you!" + ] + + PublishNoSummary -> + Help.docReport "NO SUMMARY" + (Just "elm.json") + (D.fillSep <| + [ D.fromChars "To" + , D.fromChars "publish" + , D.fromChars "a" + , D.fromChars "package," + , D.fromChars "your" + , D.fromChars "elm.json" + , D.fromChars "must" + , D.fromChars "have" + , D.fromChars "a" + , D.dullyellow (D.fromChars "\"summary\"") + , D.fromChars "field" + , D.fromChars "that" + , D.fromChars "gives" + , D.fromChars "a" + , D.fromChars "consice" + , D.fromChars "overview" + , D.fromChars "of" + , D.fromChars "your" + , D.fromChars "project." + ] + ) + [ D.reflow <| + "The summary must be less than 80 characters. It should describe the concrete use of your package as clearly and as plainly as possible." + ] + + PublishNoExposed -> + Help.docReport "NO EXPOSED MODULES" + (Just "elm.json") + (D.fillSep <| + [ D.fromChars "To" + , D.fromChars "publish" + , D.fromChars "a" + , D.fromChars "package," + , D.fromChars "the" + , D.dullyellow (D.fromChars "\"exposed-modules\"") + , D.fromChars "field" + , D.fromChars "of" + , D.fromChars "your" + , D.fromChars "elm.json" + , D.fromChars "must" + , D.fromChars "list" + , D.fromChars "at" + , D.fromChars "least" + , D.fromChars "one" + , D.fromChars "module." + ] + ) + [ D.reflow <| + "Which modules do you want users of the package to have access to? Add their names to the \"exposed-modules\" list." + ] + + PublishNoReadme -> + toBadReadmeReport "NO README" <| + "Every published package must have a helpful README.md file, but I do not see one in your project." + + PublishShortReadme -> + toBadReadmeReport "SHORT README" <| + "This README.md is too short. Having more details will help people assess your package quickly and fairly." + + PublishNoLicense -> + Help.report "NO LICENSE FILE" + (Just "LICENSE") + "By publishing a package you are inviting the Elm community to build upon your work. But without knowing your license, we have no idea if that is legal!" + [ D.reflow <| + "Once you pick an OSI approved license from , you must share that choice in two places. First, the license identifier must appear in your elm.json file. Second, the full license text must appear in the root of your project in a file named LICENSE. Add that file and you will be all set!" + ] + + PublishBuildProblem buildProblem -> + toBuildProblemReport buildProblem + + PublishMissingTag version -> + let + vsn : String + vsn = + V.toChars version + in + Help.docReport "NO TAG" + Nothing + (D.fillSep <| + [ D.fromChars "Packages" + , D.fromChars "must" + , D.fromChars "be" + , D.fromChars "tagged" + , D.fromChars "in" + , D.fromChars "git," + , D.fromChars "but" + , D.fromChars "I" + , D.fromChars "cannot" + , D.fromChars "find" + , D.fromChars "a" + , D.green (D.fromChars vsn) + , D.fromChars "tag." + ] + ) + [ D.vcat + [ D.fromChars "These tags make it possible to find this specific version on GitHub." + , D.fromChars "To tag the most recent commit and push it to GitHub, run this:" + ] + , D.indent 4 <| + D.dullyellow <| + D.vcat <| + List.map D.fromChars <| + [ "git tag -a " ++ vsn ++ " -m \"new release\"" + , "git push origin " ++ vsn + ] + , D.fromChars "The -m flag is for a helpful message. Try to make it more informative!" + ] + + PublishCannotGetTag version httpError -> + case httpError of + Http.BadHttp _ (Utils.StatusCodeException response _) -> + if Utils.httpStatusCode (Utils.httpResponseStatus response) == 404 then + let + vsn : String + vsn = + V.toChars version + in + Help.report "NO TAG ON GITHUB" + Nothing + ("You have version " ++ vsn ++ " tagged locally, but not on GitHub.") + [ D.reflow + "Run the following command to make this tag available on GitHub:" + , D.indent 4 <| + D.dullyellow <| + D.fromChars <| + "git push origin " + ++ vsn + , D.reflow + "This will make it possible to find your code online based on the version number." + ] + + else + toHttpErrorReport "PROBLEM VERIFYING TAG" + httpError + "I need to check that the version tag is registered on GitHub" + + _ -> + toHttpErrorReport "PROBLEM VERIFYING TAG" + httpError + "I need to check that the version tag is registered on GitHub" + + PublishCannotGetTagData version url body -> + Help.report "PROBLEM VERIFYING TAG" + Nothing + ("I need to check that version " ++ V.toChars version ++ " is tagged on GitHub, so I fetched:") + [ D.indent 4 <| D.dullyellow <| D.fromChars url + , D.reflow <| + "I got the data back, but it was not what I was expecting. The response body contains " + ++ String.fromInt (String.length body) + ++ " bytes. Here is the " + ++ (if String.length body <= 76 then + "whole thing:" + + else + "beginning:" + ) + , D.indent 4 <| + D.dullyellow <| + D.fromChars <| + if String.length body <= 76 then + body + + else + String.left 73 body ++ "..." + , D.reflow <| + "Does this error keep showing up? Maybe there is something weird with your internet connection. We have gotten reports that schools, businesses, airports, etc. sometimes intercept requests and add things to the body or change its contents entirely. Could that be the problem?" + ] + + PublishCannotGetZip httpError -> + toHttpErrorReport "PROBLEM DOWNLOADING CODE" httpError <| + "I need to check that folks can download and build the source code when they install this package" + + PublishCannotDecodeZip url -> + Help.report "PROBLEM DOWNLOADING CODE" + Nothing + "I need to check that folks can download and build the source code when they install this package, so I downloaded the code from:" + [ D.indent 4 <| D.dullyellow <| D.fromChars url + , D.reflow <| + "I was unable to unzip the archive though. Maybe there is something weird with your internet connection. We have gotten reports that schools, businesses, airports, etc. sometimes intercept requests and add things to the body or change its contents entirely. Could that be the problem?" + ] + + PublishCannotGetDocs old new docsProblem -> + toDocsProblemReport docsProblem <| + "I need the docs for " + ++ V.toChars old + ++ " to verify that " + ++ V.toChars new + ++ " really does come next" + + PublishCannotRegister httpError -> + toHttpErrorReport "PROBLEM PUBLISHING PACKAGE" httpError <| + "I need to send information about your package to the package website" + + PublishNoGit -> + Help.report "NO GIT" + Nothing + "I searched your PATH environment variable for `git` and could not find it. Is it available through your PATH?" + [ D.reflow <| + "Who cares about this? Well, I currently use `git` to check if there are any local changes in your code. Local changes are a good sign that some important improvements have gotten mistagged, so this check can be extremely helpful for package authors!" + , D.toSimpleNote <| + "We plan to do this without the `git` binary in a future release." + ] + + PublishLocalChanges version -> + let + vsn : String + vsn = + V.toChars version + in + Help.docReport "LOCAL CHANGES" + Nothing + (D.fillSep <| + [ D.fromChars "The" + , D.fromChars "code" + , D.fromChars "tagged" + , D.fromChars "as" + , D.green (D.fromChars vsn) + , D.fromChars "in" + , D.fromChars "git" + , D.fromChars "does" + , D.fromChars "not" + , D.fromChars "match" + , D.fromChars "the" + , D.fromChars "code" + , D.fromChars "in" + , D.fromChars "your" + , D.fromChars "working" + , D.fromChars "directory." + , D.fromChars "This" + , D.fromChars "means" + , D.fromChars "you" + , D.fromChars "have" + , D.fromChars "commits" + , D.fromChars "or" + , D.fromChars "local" + , D.fromChars "changes" + , D.fromChars "that" + , D.fromChars "are" + , D.fromChars "not" + , D.fromChars "going" + , D.fromChars "to" + , D.fromChars "be" + , D.fromChars "published!" + ] + ) + [ D.toSimpleNote <| + "If you are sure everything is in order, you can run `git checkout " + ++ vsn + ++ "` and publish your code from there." + ] + + PublishZipBadDetails _ -> + badZipReport + + PublishZipApplication -> + badZipReport + + PublishZipNoExposed -> + badZipReport + + PublishZipBuildProblem _ -> + badZipReport + + +toBadReadmeReport : String -> String -> Help.Report +toBadReadmeReport title summary = + Help.report title + (Just "README.md") + summary + [ D.reflow <| + "When people look at your README, they are wondering:" + , D.vcat + [ D.fromChars " - What does this package even do?" + , D.fromChars " - Will it help me solve MY problems?" + ] + , D.reflow <| + "So I recommend starting your README with a small example of the most common usage scenario. Show people what they can expect if they learn more!" + , D.toSimpleNote <| + "By publishing your package, you are inviting people to invest time in understanding your work. Spending an hour on your README to communicate your knowledge more clearly can save the community days or weeks of time in aggregate, and saving time in aggregate is the whole point of publishing packages! People really appreciate it, and it makes the whole ecosystem feel nicer!" + ] + + +badZipReport : Help.Report +badZipReport = + Help.report "PROBLEM VERIFYING PACKAGE" + Nothing + "Before publishing packages, I download the code from GitHub and try to build it from scratch. That way I can be more confident that it will work for other people too. But I am not able to build it!" + [ D.reflow <| + "I was just able to build your local copy though. Is there some way the version on GitHub could be different?" + ] + + + +-- DOCS + + +type DocsProblem + = DP_Http Http.Error + | DP_Data String String + | DP_Cache + + +toDocsProblemReport : DocsProblem -> String -> Help.Report +toDocsProblemReport problem context = + case problem of + DP_Http httpError -> + toHttpErrorReport "PROBLEM LOADING DOCS" httpError context + + DP_Data url body -> + Help.report "PROBLEM LOADING DOCS" + Nothing + (context ++ ", so I fetched:") + [ D.indent 4 <| D.dullyellow <| D.fromChars url + , D.reflow <| + "I got the data back, but it was not what I was expecting. The response body contains " + ++ body + ++ " bytes. Here is the " + ++ (if String.length body <= 76 then + "whole thing:" + + else + "beginning:" + ) + , D.indent 4 <| + D.dullyellow <| + D.fromChars <| + if String.length body <= 76 then + body + + else + String.left 73 body ++ "..." + , D.reflow <| + "Does this error keep showing up? Maybe there is something weird with your internet connection. We have gotten reports that schools, businesses, airports, etc. sometimes intercept requests and add things to the body or change its contents entirely. Could that be the problem?" + ] + + DP_Cache -> + Help.report "PROBLEM LOADING DOCS" + Nothing + (context ++ ", but the local copy seems to be corrupted.") + [ D.reflow <| + "I deleted the cached version, so the next run should download a fresh copy of the docs. Hopefully that will get you unstuck, but it will not resolve the root problem if, for example, a 3rd party editor plugin is modifing cached files for some reason." + ] + + + +-- INSTALL + + +type Install + = InstallNoOutline + | InstallBadOutline Outline + | InstallBadRegistry RegistryProblem + | InstallNoArgs FilePath + | InstallNoOnlineAppSolution Pkg.Name + | InstallNoOfflineAppSolution Pkg.Name + | InstallNoOnlinePkgSolution Pkg.Name + | InstallNoOfflinePkgSolution Pkg.Name + | InstallHadSolverTrouble Solver + | InstallUnknownPackageOnline Pkg.Name (List Pkg.Name) + | InstallUnknownPackageOffline Pkg.Name (List Pkg.Name) + | InstallBadDetails Details + + +installToReport : Install -> Help.Report +installToReport exit = + case exit of + InstallNoOutline -> + Help.report "NEW PROJECT?" + Nothing + "Are you trying to start a new project? Try this command instead:" + [ D.indent 4 <| D.green (D.fromChars "guida init") + , D.reflow "It will help you get started!" + ] + + InstallBadOutline outline -> + toOutlineReport outline + + InstallBadRegistry problem -> + toRegistryProblemReport "PROBLEM LOADING PACKAGE LIST" problem <| + "I need the list of published packages to figure out how to install things" + + InstallNoArgs elmHome -> + Help.report "INSTALL WHAT?" + Nothing + "I am expecting commands like:" + [ D.green <| + D.indent 4 <| + D.vcat <| + [ D.fromChars "guida install elm/http" + , D.fromChars "guida install elm/json" + , D.fromChars "guida install elm/random" + ] + , D.toFancyHint + [ D.fromChars "In" + , D.fromChars "JavaScript" + , D.fromChars "folks" + , D.fromChars "run" + , D.fromChars "`npm install`" + , D.fromChars "to" + , D.fromChars "start" + , D.fromChars "projects." + , D.fromChars "\"Gotta" + , D.fromChars "download" + , D.fromChars "everything!\"" + , D.fromChars "But" + , D.fromChars "why" + , D.fromChars "download" + , D.fromChars "packages" + , D.fromChars "again" + , D.fromChars "and" + , D.fromChars "again?" + , D.fromChars "Instead," + , D.fromChars "Elm" + , D.fromChars "caches" + , D.fromChars "packages" + , D.fromChars "in" + , D.dullyellow (D.fromChars elmHome) + , D.fromChars "so" + , D.fromChars "each" + , D.fromChars "one" + , D.fromChars "is" + , D.fromChars "downloaded" + , D.fromChars "and" + , D.fromChars "built" + , D.fromChars "ONCE" + , D.fromChars "on" + , D.fromChars "your" + , D.fromChars "machine." + , D.fromChars "Elm" + , D.fromChars "projects" + , D.fromChars "check" + , D.fromChars "that" + , D.fromChars "cache" + , D.fromChars "before" + , D.fromChars "trying" + , D.fromChars "the" + , D.fromChars "internet." + , D.fromChars "This" + , D.fromChars "reduces" + , D.fromChars "build" + , D.fromChars "times," + , D.fromChars "reduces" + , D.fromChars "server" + , D.fromChars "costs," + , D.fromChars "and" + , D.fromChars "makes" + , D.fromChars "it" + , D.fromChars "easier" + , D.fromChars "to" + , D.fromChars "work" + , D.fromChars "offline." + , D.fromChars "As" + , D.fromChars "a" + , D.fromChars "result" + , D.dullcyan (D.fromChars "elm install") + , D.fromChars "is" + , D.fromChars "only" + , D.fromChars "for" + , D.fromChars "adding" + , D.fromChars "dependencies" + , D.fromChars "to" + , D.fromChars "elm.json," + , D.fromChars "whereas" + , D.dullcyan (D.fromChars "elm make") + , D.fromChars "is" + , D.fromChars "in" + , D.fromChars "charge" + , D.fromChars "of" + , D.fromChars "gathering" + , D.fromChars "dependencies" + , D.fromChars "and" + , D.fromChars "building" + , D.fromChars "everything." + , D.fromChars "So" + , D.fromChars "maybe" + , D.fromChars "try" + , D.green (D.fromChars "elm make") + , D.fromChars "instead?" + ] + ] + + InstallNoOnlineAppSolution pkg -> + Help.report "CANNOT FIND COMPATIBLE VERSION" + (Just "elm.json") + ("I cannot find a version of " ++ Pkg.toChars pkg ++ " that is compatible with your existing dependencies.") + [ D.reflow <| + "I checked all the published versions. When that failed, I tried to find any compatible combination of these packages, even if it meant changing all your existing dependencies! That did not work either!" + , D.reflow <| + "This is most likely to happen when a package is not upgraded yet. Maybe a new version of Elm came out recently? Maybe a common package was changed recently? Maybe a better package came along, so there was no need to upgrade this one? Try asking around https://elm-lang.org/community to learn what might be going on with this package." + , D.toSimpleNote <| + "Whatever the case, please be kind to the relevant package authors! Having friendly interactions with users is great motivation, and conversely, getting berated by strangers on the internet sucks your soul dry. Furthermore, package authors are humans with families, friends, jobs, vacations, responsibilities, goals, etc. They face obstacles outside of their technical work you will never know about, so please assume the best and try to be patient and supportive!" + ] + + InstallNoOfflineAppSolution pkg -> + Help.report "CANNOT FIND COMPATIBLE VERSION LOCALLY" + (Just "elm.json") + ("I cannot find a version of " ++ Pkg.toChars pkg ++ " that is compatible with your existing dependencies.") + [ D.reflow <| + "I was not able to connect to https://package.elm-lang.org/ though, so I was only able to look through packages that you have downloaded in the past." + , D.reflow <| + "Try again later when you have internet!" + ] + + InstallNoOnlinePkgSolution pkg -> + Help.report "CANNOT FIND COMPATIBLE VERSION" + (Just "elm.json") + ("I cannot find a version of " ++ Pkg.toChars pkg ++ " that is compatible with your existing constraints.") + [ D.reflow <| + "With applications, I try to broaden the constraints to see if anything works, but messing with package constraints is much more delicate business. E.g. making your constraints stricter may make it harder for applications to find compatible dependencies. So fixing something here may break it for a lot of other people!" + , D.reflow <| + "So I recommend making an application with the same dependencies as your package. See if there is a solution at all. From there it may be easier to figure out how to proceed in a way that will disrupt your users as little as possible. And the solution may be to help other package authors to get their packages updated, or to drop a dependency entirely." + ] + + InstallNoOfflinePkgSolution pkg -> + Help.report "CANNOT FIND COMPATIBLE VERSION LOCALLY" + (Just "elm.json") + ("I cannot find a version of " ++ Pkg.toChars pkg ++ " that is compatible with your existing constraints.") + [ D.reflow <| + "I was not able to connect to https://package.elm-lang.org/ though, so I was only able to look through packages that you have downloaded in the past." + , D.reflow <| + "Try again later when you have internet!" + ] + + InstallHadSolverTrouble solver -> + toSolverReport solver + + InstallUnknownPackageOnline pkg suggestions -> + Help.docReport "UNKNOWN PACKAGE" + Nothing + (D.fillSep + [ D.fromChars "I" + , D.fromChars "cannot" + , D.fromChars "find" + , D.fromChars "a" + , D.fromChars "package" + , D.fromChars "named" + , D.red (D.fromPackage pkg) + |> D.a (D.fromChars ".") + ] + ) + [ D.reflow <| + "I looked through https://package.elm-lang.org for packages with similar names and found these:" + , D.indent 4 <| D.dullyellow <| D.vcat <| List.map D.fromPackage suggestions + , D.reflow <| "Maybe you want one of these instead?" + ] + + InstallUnknownPackageOffline pkg suggestions -> + Help.docReport "UNKNOWN PACKAGE" + Nothing + (D.fillSep + [ D.fromChars "I" + , D.fromChars "cannot" + , D.fromChars "find" + , D.fromChars "a" + , D.fromChars "package" + , D.fromChars "named" + , D.red (D.fromPackage pkg) + |> D.a (D.fromChars ".") + ] + ) + [ D.reflow <| + "I could not connect to https://package.elm-lang.org though, so new packages may have been published since I last updated my local cache of package names." + , D.reflow <| + "Looking through the locally cached names, the closest ones are:" + , D.indent 4 <| D.dullyellow <| D.vcat <| List.map D.fromPackage suggestions + , D.reflow <| "Maybe you want one of these instead?" + ] + + InstallBadDetails details -> + toDetailsReport details + + + +-- UNINSTALL + + +type Uninstall + = UninstallNoOutline + | UninstallBadOutline Outline + | UninstallBadRegistry RegistryProblem + | UninstallNoArgs + | UninstallNoOnlineAppSolution Pkg.Name + | UninstallNoOfflineAppSolution Pkg.Name + | UninstallHadSolverTrouble Solver + | UninstallBadDetails Details + + +uninstallToReport : Uninstall -> Help.Report +uninstallToReport exit = + case exit of + UninstallNoOutline -> + Help.report "NEW PROJECT?" + Nothing + "Are you trying to start a new project? Try this command instead:" + [ D.indent 4 <| D.green (D.fromChars "guida init") + , D.reflow "It will help you get started!" + ] + + UninstallBadOutline outline -> + toOutlineReport outline + + UninstallBadRegistry problem -> + toRegistryProblemReport "PROBLEM LOADING PACKAGE LIST" problem <| + "I need the list of published packages to figure out how to uninstall things" + + UninstallNoArgs -> + Help.report "UNINSTALL WHAT?" + Nothing + "I am expecting commands like:" + [ D.green <| + D.indent 4 <| + D.vcat <| + [ D.fromChars "guida uninstall elm/http" + , D.fromChars "guida uninstall elm/json" + , D.fromChars "guida uninstall elm/random" + ] + ] + + UninstallNoOnlineAppSolution pkg -> + Help.report "CANNOT FIND COMPATIBLE VERSION" + (Just "elm.json") + ("I cannot find a version of " ++ Pkg.toChars pkg ++ " that is compatible with your existing dependencies.") + [ D.reflow <| + "I checked all the published versions. When that failed, I tried to find any compatible combination of these packages, even if it meant changing all your existing dependencies! That did not work either!" + , D.reflow <| + "This is most likely to happen when a package is not upgraded yet. Maybe a new version of Elm came out recently? Maybe a common package was changed recently? Maybe a better package came along, so there was no need to upgrade this one? Try asking around https://elm-lang.org/community to learn what might be going on with this package." + , D.toSimpleNote <| + "Whatever the case, please be kind to the relevant package authors! Having friendly interactions with users is great motivation, and conversely, getting berated by strangers on the internet sucks your soul dry. Furthermore, package authors are humans with families, friends, jobs, vacations, responsibilities, goals, etc. They face obstacles outside of their technical work you will never know about, so please assume the best and try to be patient and supportive!" + ] + + UninstallNoOfflineAppSolution pkg -> + Help.report "CANNOT FIND COMPATIBLE VERSION LOCALLY" + (Just "elm.json") + ("I cannot find a version of " ++ Pkg.toChars pkg ++ " that is compatible with your existing dependencies.") + [ D.reflow <| + "I was not able to connect to https://package.elm-lang.org/ though, so I was only able to look through packages that you have downloaded in the past." + , D.reflow <| + "Try again later when you have internet!" + ] + + UninstallHadSolverTrouble solver -> + toSolverReport solver + + UninstallBadDetails details -> + toDetailsReport details + + + +-- SOLVER + + +type Solver + = SolverBadCacheData Pkg.Name V.Version + | SolverBadHttpData Pkg.Name V.Version String + | SolverBadHttp Pkg.Name V.Version Http.Error + + +toSolverReport : Solver -> Help.Report +toSolverReport problem = + case problem of + SolverBadCacheData pkg vsn -> + Help.report "PROBLEM SOLVING PACKAGE CONSTRAINTS" + Nothing + ("I need the elm.json of " ++ Pkg.toChars pkg ++ " " ++ V.toChars vsn ++ " to help me search for a set of compatible packages. I had it cached locally, but it looks like the file was corrupted!") + [ D.reflow <| + "I deleted the cached version, so the next run should download a fresh copy. Hopefully that will get you unstuck, but it will not resolve the root problem if a 3rd party tool is modifing cached files for some reason." + ] + + SolverBadHttpData pkg vsn url -> + Help.report "PROBLEM SOLVING PACKAGE CONSTRAINTS" + Nothing + ("I need the elm.json of " ++ Pkg.toChars pkg ++ " " ++ V.toChars vsn ++ " to help me search for a set of compatible packages, but I ran into corrupted information from:") + [ D.indent 4 <| D.dullyellow <| D.fromChars url + , D.reflow <| + "Is something weird with your internet connection. We have gotten reports that schools, businesses, airports, etc. sometimes intercept requests and add things to the body or change its contents entirely. Could that be the problem?" + ] + + SolverBadHttp pkg vsn httpError -> + toHttpErrorReport "PROBLEM SOLVING PACKAGE CONSTRAINTS" httpError <| + "I need the elm.json of " + ++ Pkg.toChars pkg + ++ " " + ++ V.toChars vsn + ++ " to help me search for a set of compatible packages" + + + +-- OUTLINE + + +type Outline + = OutlineHasBadStructure (Decode.Error OutlineProblem) + | OutlineHasMissingSrcDirs FilePath (List FilePath) + | OutlineHasDuplicateSrcDirs FilePath FilePath FilePath + | OutlineNoPkgCore + | OutlineNoAppCore + | OutlineNoAppJson + + +type OutlineProblem + = OP_BadType + | OP_BadPkgName Row Col + | OP_BadVersion Row Col + | OP_BadConstraint C.Error + | OP_BadModuleName Row Col + | OP_BadModuleHeaderTooLong + | OP_BadDependencyName Row Col + | OP_BadLicense (List String) + | OP_BadSummaryTooLong + | OP_NoSrcDirs + + +toOutlineReport : Outline -> Help.Report +toOutlineReport problem = + case problem of + OutlineHasBadStructure decodeError -> + Json.toReport "elm.json" (Json.FailureToReport toOutlineProblemReport) decodeError <| + Json.ExplicitReason "I ran into a problem with your elm.json file." + + OutlineHasMissingSrcDirs dir dirs -> + case dirs of + [] -> + Help.report "MISSING SOURCE DIRECTORY" + (Just "elm.json") + "I need a valid elm.json file, but the \"source-directories\" field lists the following directory:" + [ D.indent 4 <| D.red <| D.fromChars dir + , D.reflow <| + "I cannot find it though. Is it missing? Is there a typo?" + ] + + _ :: _ -> + Help.report "MISSING SOURCE DIRECTORIES" + (Just "elm.json") + "I need a valid elm.json file, but the \"source-directories\" field lists the following directories:" + [ D.indent 4 <| + D.vcat <| + List.map (D.red << D.fromChars) (dir :: dirs) + , D.reflow <| + "I cannot find them though. Are they missing? Are there typos?" + ] + + OutlineHasDuplicateSrcDirs canonicalDir dir1 dir2 -> + if dir1 == dir2 then + Help.report "REDUNDANT SOURCE DIRECTORIES" + (Just "elm.json") + "I need a valid elm.json file, but the \"source-directories\" field lists the same directory twice:" + [ D.indent 4 <| + D.vcat <| + List.map (D.red << D.fromChars) [ dir1, dir2 ] + , D.reflow <| + "Remove one of the entries!" + ] + + else + Help.report "REDUNDANT SOURCE DIRECTORIES" + (Just "elm.json") + "I need a valid elm.json file, but the \"source-directories\" field has some redundant directories:" + [ D.indent 4 <| + D.vcat <| + List.map (D.red << D.fromChars) [ dir1, dir2 ] + , D.reflow <| + "These are two different ways of refering to the same directory:" + , D.indent 4 <| D.dullyellow <| D.fromChars canonicalDir + , D.reflow <| + "Remove one of the redundant entries from your \"source-directories\" field." + ] + + OutlineNoPkgCore -> + Help.report "MISSING DEPENDENCY" + (Just "elm.json") + "I need to see an \"elm/core\" dependency your elm.json file. The default imports of `List` and `Maybe` do not work without it." + [ D.reflow <| + "If you modified your elm.json by hand, try to change it back! And if you are having trouble getting back to a working elm.json, it may be easier to find a working package and start fresh with their elm.json file." + ] + + OutlineNoAppCore -> + Help.report "MISSING DEPENDENCY" + (Just "elm.json") + "I need to see an \"elm/core\" dependency your elm.json file. The default imports of `List` and `Maybe` do not work without it." + [ D.reflow <| + "If you modified your elm.json by hand, try to change it back! And if you are having trouble getting back to a working elm.json, it may be easier to delete it and use `elm init` to start fresh." + ] + + OutlineNoAppJson -> + Help.report "MISSING DEPENDENCY" + (Just "elm.json") + "I need to see an \"elm/json\" dependency your elm.json file. It helps me handle flags and ports." + [ D.reflow <| + "If you modified your elm.json by hand, try to change it back! And if you are having trouble getting back to a working elm.json, it may be easier to delete it and use `elm init` to start fresh." + ] + + +toOutlineProblemReport : FilePath -> Code.Source -> Json.Context -> A.Region -> OutlineProblem -> Help.Report +toOutlineProblemReport path source _ region problem = + let + toHighlight : Int -> Int -> Maybe A.Region + toHighlight row col = + Just <| A.Region (A.Position row col) (A.Position row col) + + toSnippet : String -> Maybe A.Region -> ( D.Doc, D.Doc ) -> Help.Report + toSnippet title highlight pair = + Help.jsonReport title (Just path) <| + Code.toSnippet source region highlight pair + in + case problem of + OP_BadType -> + toSnippet "UNEXPECTED TYPE" + Nothing + ( D.reflow <| + "I got stuck while reading your elm.json file. I cannot handle a \"type\" like this:" + , D.fillSep + [ D.fromChars "Try" + , D.fromChars "changing" + , D.fromChars "the" + , D.fromChars "\"type\"" + , D.fromChars "to" + , D.green (D.fromChars "\"application\"") + , D.fromChars "or" + , D.green (D.fromChars "\"package\"") + , D.fromChars "instead." + ] + ) + + OP_BadPkgName row col -> + toSnippet "INVALID PACKAGE NAME" + (toHighlight row col) + ( D.reflow <| + "I got stuck while reading your elm.json file. I ran into trouble with the package name:" + , D.stack + [ D.fillSep + [ D.fromChars "Package" + , D.fromChars "names" + , D.fromChars "are" + , D.fromChars "always" + , D.fromChars "written" + , D.fromChars "as" + , D.green (D.fromChars "\"author/project\"") + , D.fromChars "so" + , D.fromChars "I" + , D.fromChars "am" + , D.fromChars "expecting" + , D.fromChars "to" + , D.fromChars "see" + , D.fromChars "something" + , D.fromChars "like:" + ] + , D.dullyellow <| + D.indent 4 <| + D.vcat <| + [ D.fromChars "\"mdgriffith/elm-ui\"" + , D.fromChars "\"w0rm/elm-physics\"" + , D.fromChars "\"Microsoft/elm-json-tree-view\"" + , D.fromChars "\"FordLabs/elm-star-rating\"" + , D.fromChars "\"1602/json-schema\"" + ] + , D.reflow + "The author name should match your GitHub name exactly, and the project name needs to follow these rules:" + , D.indent 4 <| + D.vcat <| + [ D.fromChars "+--------------------------------------+-----------+-----------+" + , D.fromChars "| RULE | BAD | GOOD |" + , D.fromChars "+--------------------------------------+-----------+-----------+" + , D.fromChars "| only lower case, digits, and hyphens | elm-HTTP | elm-http |" + , D.fromChars "| no leading digits | 3D | elm-3d |" + , D.fromChars "| no non-ASCII characters | elm-bjørn | elm-bear |" + , D.fromChars "| no underscores | elm_ui | elm-ui |" + , D.fromChars "| no double hyphens | elm--hash | elm-hash |" + , D.fromChars "| no starting or ending hyphen | -elm-tar- | elm-tar |" + , D.fromChars "+--------------------------------------+-----------+-----------+" + ] + , D.toSimpleNote <| + "These rules only apply to the project name, so you should never need to change your GitHub name!" + ] + ) + + OP_BadVersion row col -> + toSnippet "PROBLEM WITH VERSION" + (toHighlight row col) + ( D.reflow <| + "I got stuck while reading your elm.json file. I was expecting a version number here:" + , D.fillSep + [ D.fromChars "I" + , D.fromChars "need" + , D.fromChars "something" + , D.fromChars "like" + , D.green (D.fromChars "\"1.0.0\"") + , D.fromChars "or" + , D.green (D.fromChars "\"2.0.4\"") + , D.fromChars "that" + , D.fromChars "explicitly" + , D.fromChars "states" + , D.fromChars "all" + , D.fromChars "three" + , D.fromChars "numbers!" + ] + ) + + OP_BadConstraint constraintError -> + case constraintError of + C.BadFormat row col -> + toSnippet "PROBLEM WITH CONSTRAINT" + (toHighlight row col) + ( D.reflow <| + "I got stuck while reading your elm.json file. I do not understand this version constraint:" + , D.stack + [ D.fillSep + [ D.fromChars "I" + , D.fromChars "need" + , D.fromChars "something" + , D.fromChars "like" + , D.green (D.fromChars "\"1.0.0 <= v < 2.0.0\"") + , D.fromChars "that" + , D.fromChars "explicitly" + , D.fromChars "lists" + , D.fromChars "the" + , D.fromChars "lower" + , D.fromChars "and" + , D.fromChars "upper" + , D.fromChars "bounds." + ] + , D.toSimpleNote <| + "The spaces in there are required! Taking them out will confuse me. Adding extra spaces confuses me too. I recommend starting with a valid example and just changing the version numbers." + ] + ) + + C.InvalidRange before after -> + if before == after then + toSnippet "PROBLEM WITH CONSTRAINT" + Nothing + ( D.reflow <| + "I got stuck while reading your elm.json file. I ran into an invalid version constraint:" + , D.fillSep + [ D.fromChars "Elm" + , D.fromChars "checks" + , D.fromChars "that" + , D.fromChars "all" + , D.fromChars "package" + , D.fromChars "APIs" + , D.fromChars "follow" + , D.fromChars "semantic" + , D.fromChars "versioning," + , D.fromChars "so" + , D.fromChars "it" + , D.fromChars "is" + , D.fromChars "best" + , D.fromChars "to" + , D.fromChars "use" + , D.fromChars "wide" + , D.fromChars "constraints." + , D.fromChars "I" + , D.fromChars "recommend" + , D.green (D.fromChars "\"") |> D.a (D.fromVersion before) |> D.a (D.fromChars " <= v < ") |> D.a (D.fromVersion (V.bumpMajor after)) |> D.a (D.fromChars "\"") + , D.fromChars "since" + , D.fromChars "it" + , D.fromChars "is" + , D.fromChars "guaranteed" + , D.fromChars "that" + , D.fromChars "breaking" + , D.fromChars "API" + , D.fromChars "changes" + , D.fromChars "cannot" + , D.fromChars "happen" + , D.fromChars "in" + , D.fromChars "any" + , D.fromChars "of" + , D.fromChars "the" + , D.fromChars "versions" + , D.fromChars "in" + , D.fromChars "that" + , D.fromChars "range." + ] + ) + + else + toSnippet "PROBLEM WITH CONSTRAINT" + Nothing + ( D.reflow <| + "I got stuck while reading your elm.json file. I ran into an invalid version constraint:" + , D.fillSep + [ D.fromChars "Maybe" + , D.fromChars "you" + , D.fromChars "want" + , D.fromChars "something" + , D.fromChars "like" + , D.green + (D.fromChars "\"" + |> D.a (D.fromVersion before) + |> D.a (D.fromChars " <= v < ") + |> D.a (D.fromVersion (V.bumpMajor before)) + |> D.a (D.fromChars "\"") + ) + , D.fromChars "instead?" + , D.fromChars "Elm" + , D.fromChars "checks" + , D.fromChars "that" + , D.fromChars "all" + , D.fromChars "package" + , D.fromChars "APIs" + , D.fromChars "follow" + , D.fromChars "semantic" + , D.fromChars "versioning," + , D.fromChars "so" + , D.fromChars "it" + , D.fromChars "is" + , D.fromChars "guaranteed" + , D.fromChars "that" + , D.fromChars "breaking" + , D.fromChars "API" + , D.fromChars "changes" + , D.fromChars "cannot" + , D.fromChars "happen" + , D.fromChars "in" + , D.fromChars "any" + , D.fromChars "of" + , D.fromChars "the" + , D.fromChars "versions" + , D.fromChars "in" + , D.fromChars "that" + , D.fromChars "range." + ] + ) + + OP_BadModuleName row col -> + toSnippet "PROBLEM WITH MODULE NAME" + (toHighlight row col) + ( D.reflow <| + "I got stuck while reading your elm.json file. I was expecting a module name here:" + , D.fillSep + [ D.fromChars "I" + , D.fromChars "need" + , D.fromChars "something" + , D.fromChars "like" + , D.green (D.fromChars "\"Html.Events\"") + , D.fromChars "or" + , D.green (D.fromChars "\"Browser.Navigation\"") + , D.fromChars "where" + , D.fromChars "each" + , D.fromChars "segment" + , D.fromChars "starts" + , D.fromChars "with" + , D.fromChars "a" + , D.fromChars "capital" + , D.fromChars "letter" + , D.fromChars "and" + , D.fromChars "the" + , D.fromChars "segments" + , D.fromChars "are" + , D.fromChars "separated" + , D.fromChars "by" + , D.fromChars "dots." + ] + ) + + OP_BadModuleHeaderTooLong -> + toSnippet "HEADER TOO LONG" + Nothing + ( D.reflow <| + "I got stuck while reading your elm.json file. This section header is too long:" + , D.stack + [ D.fillSep + [ D.fromChars "I" + , D.fromChars "need" + , D.fromChars "it" + , D.fromChars "to" + , D.fromChars "be" + , D.green (D.fromChars "under") + , D.green (D.fromChars "20") + , D.green (D.fromChars "bytes") + , D.fromChars "so" + , D.fromChars "it" + , D.fromChars "renders" + , D.fromChars "nicely" + , D.fromChars "on" + , D.fromChars "the" + , D.fromChars "package" + , D.fromChars "website!" + ] + , D.toSimpleNote + "I count the length in bytes, so using non-ASCII characters costs extra. Please report your case at https://github.com/elm/compiler/issues if this seems overly restrictive for your needs." + ] + ) + + OP_BadDependencyName row col -> + toSnippet "PROBLEM WITH DEPENDENCY NAME" + (toHighlight row col) + ( D.reflow <| + "I got stuck while reading your elm.json file. There is something wrong with this dependency name:" + , D.stack + [ D.fillSep + [ D.fromChars "Package" + , D.fromChars "names" + , D.fromChars "always" + , D.fromChars "include" + , D.fromChars "the" + , D.fromChars "name" + , D.fromChars "of" + , D.fromChars "the" + , D.fromChars "author," + , D.fromChars "so" + , D.fromChars "I" + , D.fromChars "am" + , D.fromChars "expecting" + , D.fromChars "to" + , D.fromChars "see" + , D.fromChars "dependencies" + , D.fromChars "like" + , D.dullyellow (D.fromChars "\"mdgriffith/elm-ui\"") + , D.fromChars "and" + , D.dullyellow (D.fromChars "\"Microsoft/elm-json-tree-view\"") + |> D.a (D.fromChars ".") + ] + , D.fillSep <| + [ D.fromChars "I" + , D.fromChars "generally" + , D.fromChars "recommend" + , D.fromChars "finding" + , D.fromChars "the" + , D.fromChars "package" + , D.fromChars "you" + , D.fromChars "want" + , D.fromChars "on" + , D.fromChars "the" + , D.fromChars "package" + , D.fromChars "website," + , D.fromChars "and" + , D.fromChars "installing" + , D.fromChars "it" + , D.fromChars "with" + , D.fromChars "the" + , D.green (D.fromChars "elm install") + , D.fromChars "command!" + ] + ] + ) + + OP_BadLicense suggestions -> + toSnippet "UNKNOWN LICENSE" + Nothing + ( D.reflow <| + "I got stuck while reading your elm.json file. I do not know about this type of license:" + , D.stack + [ D.fillSep + [ D.fromChars "Elm" + , D.fromChars "packages" + , D.fromChars "generally" + , D.fromChars "use" + , D.green (D.fromChars "\"BSD-3-Clause\"") + , D.fromChars "or" + , D.green (D.fromChars "\"MIT\"") + |> D.a (D.fromChars ",") + , D.fromChars "but" + , D.fromChars "I" + , D.fromChars "accept" + , D.fromChars "any" + , D.fromChars "OSI" + , D.fromChars "approved" + , D.fromChars "SPDX" + , D.fromChars "license." + , D.fromChars "Here" + , D.fromChars "some" + , D.fromChars "that" + , D.fromChars "seem" + , D.fromChars "close" + , D.fromChars "to" + , D.fromChars "what" + , D.fromChars "you" + , D.fromChars "wrote:" + ] + , D.indent 4 <| D.dullyellow <| D.vcat <| List.map D.fromChars suggestions + , D.reflow <| + "Check out https://spdx.org/licenses/ for the full list of options." + ] + ) + + OP_BadSummaryTooLong -> + toSnippet "SUMMARY TOO LONG" + Nothing + ( D.reflow <| + "I got stuck while reading your elm.json file. Your \"summary\" is too long:" + , D.stack + [ D.fillSep + [ D.fromChars "I" + , D.fromChars "need" + , D.fromChars "it" + , D.fromChars "to" + , D.fromChars "be" + , D.green (D.fromChars "under") + , D.green (D.fromChars "80") + , D.green (D.fromChars "bytes") + , D.fromChars "so" + , D.fromChars "it" + , D.fromChars "renders" + , D.fromChars "nicely" + , D.fromChars "on" + , D.fromChars "the" + , D.fromChars "package" + , D.fromChars "website!" + ] + , D.toSimpleNote + "I count the length in bytes, so using non-ASCII characters costs extra. Please report your case at https://github.com/elm/compiler/issues if this seems overly restrictive for your needs." + ] + ) + + OP_NoSrcDirs -> + toSnippet "NO SOURCE DIRECTORIES" + Nothing + ( D.reflow <| + "I got stuck while reading your elm.json file. You do not have any \"source-directories\" listed here:" + , D.fillSep + [ D.fromChars "I" + , D.fromChars "need" + , D.fromChars "something" + , D.fromChars "like" + , D.green (D.fromChars "[\"src\"]") + , D.fromChars "so" + , D.fromChars "I" + , D.fromChars "know" + , D.fromChars "where" + , D.fromChars "to" + , D.fromChars "look" + , D.fromChars "for" + , D.fromChars "your" + , D.fromChars "modules!" + ] + ) + + + +-- DETAILS + + +type Details + = DetailsNoSolution + | DetailsNoOfflineSolution + | DetailsSolverProblem Solver + | DetailsBadElmInPkg C.Constraint + | DetailsBadElmInAppOutline V.Version + | DetailsHandEditedDependencies + | DetailsBadOutline Outline + | DetailsCannotGetRegistry RegistryProblem + | DetailsBadDeps FilePath (List DetailsBadDep) + + +type DetailsBadDep + = BD_BadDownload Pkg.Name V.Version PackageProblem + | BD_BadBuild Pkg.Name V.Version (Dict ( String, String ) Pkg.Name V.Version) + + +toDetailsReport : Details -> Help.Report +toDetailsReport details = + case details of + DetailsNoSolution -> + Help.report "INCOMPATIBLE DEPENDENCIES" + (Just "elm.json") + "The dependencies in your elm.json are not compatible." + [ D.fillSep + [ D.fromChars "Did" + , D.fromChars "you" + , D.fromChars "change" + , D.fromChars "them" + , D.fromChars "by" + , D.fromChars "hand?" + , D.fromChars "Try" + , D.fromChars "to" + , D.fromChars "change" + , D.fromChars "it" + , D.fromChars "back!" + , D.fromChars "It" + , D.fromChars "is" + , D.fromChars "much" + , D.fromChars "more" + , D.fromChars "reliable" + , D.fromChars "to" + , D.fromChars "add" + , D.fromChars "dependencies" + , D.fromChars "with" + , D.green (D.fromChars "elm install") + |> D.a (D.fromChars ".") + ] + , D.reflow <| + "Please ask for help on the community forums if you try those paths and are still having problems!" + ] + + DetailsNoOfflineSolution -> + Help.report "TROUBLE VERIFYING DEPENDENCIES" + (Just "elm.json") + "I could not connect to https://package.elm-lang.org to get the latest list of packages, and I was unable to verify your dependencies with the information I have cached locally." + [ D.reflow <| + "Are you able to connect to the internet? These dependencies may work once you get access to the registry!" + , D.toFancyNote + [ D.fromChars "If" + , D.fromChars "you" + , D.fromChars "changed" + , D.fromChars "your" + , D.fromChars "dependencies" + , D.fromChars "by" + , D.fromChars "hand," + , D.fromChars "try" + , D.fromChars "to" + , D.fromChars "change" + , D.fromChars "them" + , D.fromChars "back!" + , D.fromChars "It" + , D.fromChars "is" + , D.fromChars "much" + , D.fromChars "more" + , D.fromChars "reliable" + , D.fromChars "to" + , D.fromChars "add" + , D.fromChars "dependencies" + , D.fromChars "with" + , D.green (D.fromChars "elm install") + |> D.a (D.fromChars ".") + ] + ] + + DetailsSolverProblem solver -> + toSolverReport solver + + DetailsBadElmInPkg constraint -> + Help.report "ELM VERSION MISMATCH" + (Just "elm.json") + "Your elm.json says this package needs a version of Elm in this range:" + [ D.indent 4 <| D.dullyellow <| D.fromChars <| C.toChars constraint + , D.fillSep + [ D.fromChars "But" + , D.fromChars "you" + , D.fromChars "are" + , D.fromChars "using" + , D.fromChars "Elm" + , D.red (D.fromVersion V.compiler) + , D.fromChars "right" + , D.fromChars "now." + ] + ] + + DetailsBadElmInAppOutline version -> + Help.report "ELM VERSION MISMATCH" + (Just "elm.json") + "Your elm.json says this application needs a different version of Elm." + [ D.fillSep + [ D.fromChars "It" + , D.fromChars "requires" + , D.green (D.fromVersion version) + |> D.a (D.fromChars ",") + , D.fromChars "but" + , D.fromChars "you" + , D.fromChars "are" + , D.fromChars "using" + , D.red (D.fromVersion V.compiler) + , D.fromChars "right" + , D.fromChars "now." + ] + ] + + DetailsHandEditedDependencies -> + Help.report "ERROR IN DEPENDENCIES" + (Just "elm.json") + "It looks like the dependencies elm.json in were edited by hand (or by a 3rd party tool) leaving them in an invalid state." + [ D.fillSep + [ D.fromChars "Try" + , D.fromChars "to" + , D.fromChars "change" + , D.fromChars "them" + , D.fromChars "back" + , D.fromChars "to" + , D.fromChars "what" + , D.fromChars "they" + , D.fromChars "were" + , D.fromChars "before!" + , D.fromChars "It" + , D.fromChars "is" + , D.fromChars "much" + , D.fromChars "more" + , D.fromChars "reliable" + , D.fromChars "to" + , D.fromChars "add" + , D.fromChars "dependencies" + , D.fromChars "with" + , D.green (D.fromChars "elm install") + |> D.a (D.fromChars ".") + ] + , D.reflow <| + "Please ask for help on the community forums if you try those paths and are still having problems!" + ] + + DetailsBadOutline outline -> + toOutlineReport outline + + DetailsCannotGetRegistry problem -> + toRegistryProblemReport "PROBLEM LOADING PACKAGE LIST" problem <| + "I need the list of published packages to verify your dependencies" + + DetailsBadDeps cacheDir deps -> + case List.sortBy toBadDepRank deps of + [] -> + Help.report "PROBLEM BUILDING DEPENDENCIES" + Nothing + "I am not sure what is going wrong though." + [ D.reflow <| + "I would try deleting the " + ++ cacheDir + ++ " and guida-stuff/ directories, then trying to build again. That will work if some cached files got corrupted somehow." + , D.reflow <| + "If that does not work, go to https://elm-lang.org/community and ask for help. This is a weird case!" + ] + + d :: _ -> + case d of + BD_BadDownload pkg vsn packageProblem -> + toPackageProblemReport pkg vsn packageProblem + + BD_BadBuild pkg vsn fingerprint -> + Help.report "PROBLEM BUILDING DEPENDENCIES" + Nothing + "I ran into a compilation error when trying to build the following package:" + [ D.indent 4 <| D.red <| D.fromChars <| Pkg.toChars pkg ++ " " ++ V.toChars vsn + , D.reflow <| + "This probably means it has package constraints that are too wide. It may be possible to tweak your elm.json to avoid the root problem as a stopgap. Head over to https://elm-lang.org/community to get help figuring out how to take this path!" + , D.toSimpleNote <| + "To help with the root problem, please report this to the package author along with the following information:" + , D.indent 4 <| + D.vcat <| + List.map (\( p, v ) -> D.fromChars <| Pkg.toChars p ++ " " ++ V.toChars v) <| + Dict.toList compare fingerprint + , D.reflow <| + "If you want to help out even more, try building the package locally. That should give you much more specific information about why this package is failing to build, which will in turn make it easier for the package author to fix it!" + ] + + +toBadDepRank : + DetailsBadDep + -> Int -- lower is better +toBadDepRank badDep = + case badDep of + BD_BadDownload _ _ _ -> + 0 + + BD_BadBuild _ _ _ -> + 1 + + + +-- PACKAGE PROBLEM + + +type PackageProblem + = PP_BadEndpointRequest Http.Error + | PP_BadEndpointContent String + | PP_BadArchiveRequest Http.Error + | PP_BadArchiveContent String + | PP_BadArchiveHash String String String + + +toPackageProblemReport : Pkg.Name -> V.Version -> PackageProblem -> Help.Report +toPackageProblemReport pkg vsn problem = + let + thePackage : String + thePackage = + Pkg.toChars pkg ++ " " ++ V.toChars vsn + in + case problem of + PP_BadEndpointRequest httpError -> + toHttpErrorReport "PROBLEM DOWNLOADING PACKAGE" httpError <| + "I need to find the latest download link for " + ++ thePackage + + PP_BadEndpointContent url -> + Help.report "PROBLEM DOWNLOADING PACKAGE" + Nothing + ("I need to find the latest download link for " ++ thePackage ++ ", but I ran into corrupted information from:") + [ D.indent 4 <| D.dullyellow <| D.fromChars url + , D.reflow <| + "Is something weird with your internet connection. We have gotten reports that schools, businesses, airports, etc. sometimes intercept requests and add things to the body or change its contents entirely. Could that be the problem?" + ] + + PP_BadArchiveRequest httpError -> + toHttpErrorReport "PROBLEM DOWNLOADING PACKAGE" httpError <| + "I was trying to download the source code for " + ++ thePackage + + PP_BadArchiveContent url -> + Help.report "PROBLEM DOWNLOADING PACKAGE" + Nothing + ("I downloaded the source code for " ++ thePackage ++ " from:") + [ D.indent 4 <| D.dullyellow <| D.fromChars url + , D.reflow <| + "But I was unable to unzip the data. Maybe there is something weird with your internet connection. We have gotten reports that schools, businesses, airports, etc. sometimes intercept requests and add things to the body or change its contents entirely. Could that be the problem?" + ] + + PP_BadArchiveHash url expectedHash actualHash -> + Help.report "CORRUPT PACKAGE DATA" + Nothing + ("I downloaded the source code for " ++ thePackage ++ " from:") + [ D.indent 4 <| D.dullyellow <| D.fromChars url + , D.reflow "But it looks like the hash of the archive has changed since publication:" + , D.vcat <| + List.map D.fromChars <| + [ " Expected: " ++ expectedHash + , " Actual: " ++ actualHash + ] + , D.reflow <| + "This usually means that the package author moved the version tag, so report it to them and see if that is the issue. Folks on Elm slack can probably help as well." + ] + + + +-- REGISTRY PROBLEM + + +type RegistryProblem + = RP_Http Http.Error + | RP_Data String String + + +toRegistryProblemReport : String -> RegistryProblem -> String -> Help.Report +toRegistryProblemReport title problem context = + case problem of + RP_Http err -> + toHttpErrorReport title err context + + RP_Data url body -> + Help.report title + Nothing + (context ++ ", so I fetched:") + [ D.indent 4 <| D.dullyellow <| D.fromChars url + , D.reflow <| + "I got the data back, but it was not what I was expecting. The response body contains " + ++ String.fromInt (String.length body) + ++ " bytes. Here is the " + ++ (if String.length body <= 76 then + "whole thing:" + + else + "beginning:" + ) + , D.indent 4 <| + D.dullyellow <| + D.fromChars <| + if String.length body <= 76 then + body + + else + String.left 73 body ++ "..." + , D.reflow <| + "Does this error keep showing up? Maybe there is something weird with your internet connection. We have gotten reports that schools, businesses, airports, etc. sometimes intercept requests and add things to the body or change its contents entirely. Could that be the problem?" + ] + + +toHttpErrorReport : String -> Http.Error -> String -> Help.Report +toHttpErrorReport title err context = + let + toHttpReport : String -> String -> List D.Doc -> Help.Report + toHttpReport intro url details = + Help.report title Nothing intro <| + D.indent 4 (D.dullyellow (D.fromChars url)) + :: details + in + case err of + Http.BadUrl url reason -> + toHttpReport (context ++ ", so I wanted to fetch:") + url + [ D.reflow <| "But my HTTP library is saying this is not a valid URL. It is saying:" + , D.indent 4 <| D.fromChars reason + , D.reflow <| + "This may indicate that there is some problem in the compiler, so please open an issue at https://github.com/elm/compiler/issues listing your operating system, Elm version, the command you ran, the terminal output, and any additional information that might help others reproduce the error." + ] + + Http.BadHttp url httpExceptionContent -> + case httpExceptionContent of + Utils.StatusCodeException response body -> + let + (Utils.HttpStatus code message) = + Utils.httpResponseStatus response + in + toHttpReport (context ++ ", so I tried to fetch:") + url + [ D.fillSep <| + [ D.fromChars "But" + , D.fromChars "it" + , D.fromChars "came" + , D.fromChars "back" + , D.fromChars "as" + , D.red (D.fromInt code) + ] + ++ List.map D.fromChars (String.words message) + , D.indent 4 <| D.reflow <| body + , D.reflow <| + "This may mean some online endpoint changed in an unexpected way, so if does not seem like something on your side is causing this (e.g. firewall) please report this to https://github.com/elm/compiler/issues with your operating system, Elm version, the command you ran, the terminal output, and any additional information that can help others reproduce the error!" + ] + + Utils.TooManyRedirects responses -> + toHttpReport (context ++ ", so I tried to fetch:") + url + [ D.reflow <| + "But I gave up after following these " + ++ String.fromInt (List.length responses) + ++ " redirects:" + , D.indent 4 <| D.vcat <| List.map toRedirectDoc responses + , D.reflow <| + "Is it possible that your internet connection intercepts certain requests? That sometimes causes problems for folks in schools, businesses, airports, hotels, and certain countries. Try asking for help locally or in a community forum!" + ] + + _ -> + toHttpReport (context ++ ", so I tried to fetch:") + url + [ D.reflow <| "But my HTTP library is giving me the following error message:" + , D.indent 4 <| D.fromChars "TODO" + , D.reflow <| + "Are you somewhere with a slow internet connection? Or no internet? Does the link I am trying to fetch work in your browser? Maybe the site is down? Does your internet connection have a firewall that blocks certain domains? It is usually something like that!" + ] + + Http.BadMystery url Utils.SomeException -> + toHttpReport (context ++ ", so I tried to fetch:") + url + [ D.reflow <| "But I ran into something weird! I was able to extract this error message:" + , D.indent 4 <| D.fromChars "SomeException" + , D.reflow <| + "Is it possible that your internet connection intercepts certain requests? That sometimes causes problems for folks in schools, businesses, airports, hotels, and certain countries. Try asking for help locally or in a community forum!" + ] + + +toRedirectDoc : Utils.HttpResponse body -> D.Doc +toRedirectDoc response = + let + (Utils.HttpStatus code message) = + Utils.httpResponseStatus response + in + case Utils.listLookup Utils.httpHLocation (Utils.httpResponseHeaders response) of + Just loc -> + D.red (D.fromInt code) |> D.a (D.fromChars " - ") |> D.a (D.fromChars loc) + + Nothing -> + D.red (D.fromInt code) |> D.a (D.fromChars " - ") |> D.a (D.fromChars message) + + + +-- MAKE + + +type Make + = MakeNoOutline + | MakeCannotOptimizeAndDebug + | MakeBadDetails Details + | MakeAppNeedsFileNames + | MakePkgNeedsExposing + | MakeMultipleFilesIntoHtml + | MakeNoMain + | MakeNonMainFilesIntoJavaScript ModuleName.Raw (List ModuleName.Raw) + | MakeCannotBuild BuildProblem + | MakeBadGenerate Generate + + +makeToReport : Make -> Help.Report +makeToReport make = + case make of + MakeNoOutline -> + Help.report "NO elm.json FILE" + Nothing + "It looks like you are starting a new Elm project. Very exciting! Try running:" + [ D.indent 4 <| D.green <| D.fromChars "elm init" + , D.reflow <| + "It will help you get set up. It is really simple!" + ] + + MakeCannotOptimizeAndDebug -> + Help.docReport "CLASHING FLAGS" + Nothing + (D.fillSep + [ D.fromChars "I" + , D.fromChars "cannot" + , D.fromChars "compile" + , D.fromChars "with" + , D.red (D.fromChars "--optimize") + , D.fromChars "and" + , D.red (D.fromChars "--debug") + , D.fromChars "at" + , D.fromChars "the" + , D.fromChars "same" + , D.fromChars "time." + ] + ) + [ D.reflow + "I need to take away information to optimize things, and I need to add information to add the debugger. It is impossible to do both at once though! Pick just one of those flags and it should work!" + ] + + MakeBadDetails detailsProblem -> + toDetailsReport detailsProblem + + MakeAppNeedsFileNames -> + Help.report "NO INPUT" + Nothing + "What should I make though? I need specific files like:" + [ D.vcat + [ D.indent 4 <| D.green (D.fromChars "elm make src/Main.elm") + , D.indent 4 <| D.green (D.fromChars "elm make src/This.elm src/That.elm") + ] + , D.reflow <| + "I recommend reading through https://guide.elm-lang.org for guidance on what to actually put in those files!" + ] + + MakePkgNeedsExposing -> + Help.report "NO INPUT" + Nothing + "What should I make though? I need specific files like:" + [ D.vcat + [ D.indent 4 <| D.green (D.fromChars "elm make src/Main.elm") + , D.indent 4 <| D.green (D.fromChars "elm make src/This.elm src/That.elm") + ] + , D.reflow <| + "You can also entries to the \"exposed-modules\" list in your elm.json file, and I will try to compile the relevant files." + ] + + MakeMultipleFilesIntoHtml -> + Help.report "TOO MANY FILES" + Nothing + "When producing an HTML file, I can only handle one file." + [ D.fillSep + [ D.fromChars "Switch" + , D.fromChars "to" + , D.dullyellow (D.fromChars "--output=/dev/null") + , D.fromChars "if" + , D.fromChars "you" + , D.fromChars "just" + , D.fromChars "want" + , D.fromChars "to" + , D.fromChars "get" + , D.fromChars "compile" + , D.fromChars "errors." + , D.fromChars "This" + , D.fromChars "skips" + , D.fromChars "the" + , D.fromChars "code" + , D.fromChars "gen" + , D.fromChars "phase," + , D.fromChars "so" + , D.fromChars "it" + , D.fromChars "can" + , D.fromChars "be" + , D.fromChars "a" + , D.fromChars "bit" + , D.fromChars "faster" + , D.fromChars "than" + , D.fromChars "other" + , D.fromChars "options" + , D.fromChars "sometimes." + ] + , D.fillSep + [ D.fromChars "Switch" + , D.fromChars "to" + , D.dullyellow (D.fromChars "--output=elm.js") + , D.fromChars "if" + , D.fromChars "you" + , D.fromChars "want" + , D.fromChars "multiple" + , D.fromChars "`main`" + , D.fromChars "values" + , D.fromChars "available" + , D.fromChars "in" + , D.fromChars "a" + , D.fromChars "single" + , D.fromChars "JavaScript" + , D.fromChars "file." + , D.fromChars "Then" + , D.fromChars "you" + , D.fromChars "can" + , D.fromChars "make" + , D.fromChars "your" + , D.fromChars "own" + , D.fromChars "customized" + , D.fromChars "HTML" + , D.fromChars "file" + , D.fromChars "that" + , D.fromChars "embeds" + , D.fromChars "multiple" + , D.fromChars "Elm" + , D.fromChars "nodes." + , D.fromChars "The" + , D.fromChars "generated" + , D.fromChars "JavaScript" + , D.fromChars "also" + , D.fromChars "shares" + , D.fromChars "dependencies" + , D.fromChars "between" + , D.fromChars "modules," + , D.fromChars "so" + , D.fromChars "it" + , D.fromChars "should" + , D.fromChars "be" + , D.fromChars "smaller" + , D.fromChars "than" + , D.fromChars "compiling" + , D.fromChars "each" + , D.fromChars "module" + , D.fromChars "separately." + ] + ] + + MakeNoMain -> + Help.report "NO MAIN" + Nothing + "When producing an HTML file, I require that the given file has a `main` value. That way I have something to show on screen!" + [ D.reflow <| + "Try adding a `main` value to your file? Or if you just want to verify that this module compiles, switch to --output=/dev/null to skip the code gen phase altogether." + , D.toSimpleNote <| + "Adding a `main` value can be as brief as adding something like this:" + , D.vcat + [ D.fillSep + [ D.cyan (D.fromChars "import") + , D.fromChars "Html" + ] + , D.fromChars "" + , D.fillSep + [ D.green (D.fromChars "main") + , D.fromChars "=" + ] + , D.indent 2 <| + D.fillSep + [ D.cyan (D.fromChars "Html") + |> D.a (D.fromChars ".text") + , D.dullyellow (D.fromChars "\"Hello!\"") + ] + ] + , D.reflow <| + "From there I can create an HTML file that says \"Hello!\" on screen. I recommend looking through https://guide.elm-lang.org for more guidance on how to fill in the `main` value." + ] + + MakeNonMainFilesIntoJavaScript m ms -> + case ms of + [] -> + Help.report "NO MAIN" + Nothing + ("When producing a JS file, I require that the given file has a `main` value. That way Elm." + ++ String.fromList (ModuleName.toChars m) + ++ ".init() is definitely defined in the resulting file!" + ) + [ D.reflow <| + "Try adding a `main` value to your file? Or if you just want to verify that this module compiles, switch to --output=/dev/null to skip the code gen phase altogether." + , D.toSimpleNote <| + "Adding a `main` value can be as brief as adding something like this:" + , D.vcat + [ D.fillSep + [ D.cyan (D.fromChars "import") + , D.fromChars "Html" + ] + , D.fromChars "" + , D.fillSep + [ D.green (D.fromChars "main") + , D.fromChars "=" + ] + , D.indent 2 <| + D.fillSep + [ D.cyan (D.fromChars "Html") + |> D.a (D.fromChars ".text") + , D.dullyellow (D.fromChars "\"Hello!\"") + ] + ] + , D.reflow <| + "Or use https://package.elm-lang.org/packages/elm/core/latest/Platform#worker to make a `main` with no user interface." + ] + + _ :: _ -> + Help.report "NO MAIN" + Nothing + ("When producing a JS file, I require that given files all have `main` values. That way functions like Elm." + ++ String.fromList (ModuleName.toChars m) + ++ ".init() are definitely defined in the resulting file. I am missing `main` values in:" + ) + [ D.indent 4 <| D.red <| D.vcat <| List.map D.fromName (m :: ms) + , D.reflow <| + "Try adding a `main` value to them? Or if you just want to verify that these modules compile, switch to --output=/dev/null to skip the code gen phase altogether." + , D.toSimpleNote <| + "Adding a `main` value can be as brief as adding something like this:" + , D.vcat + [ D.fillSep + [ D.cyan (D.fromChars "import") + , D.fromChars "Html" + ] + , D.fromChars "" + , D.fillSep + [ D.green (D.fromChars "main") + , D.fromChars "=" + ] + , D.indent 2 <| + D.fillSep + [ D.cyan (D.fromChars "Html") + |> D.a (D.fromChars ".text") + , D.dullyellow (D.fromChars "\"Hello!\"") + ] + ] + , D.reflow <| + "Or use https://package.elm-lang.org/packages/elm/core/latest/Platform#worker to make a `main` with no user interface." + ] + + MakeCannotBuild buildProblem -> + toBuildProblemReport buildProblem + + MakeBadGenerate generateProblem -> + toGenerateReport generateProblem + + + +-- BUILD PROBLEM + + +type BuildProblem + = BuildBadModules FilePath Error.Module (List Error.Module) + | BuildProjectProblem BuildProjectProblem + + +type BuildProjectProblem + = BP_PathUnknown FilePath + | BP_WithBadExtension FilePath + | BP_WithAmbiguousSrcDir FilePath FilePath FilePath + | BP_MainPathDuplicate FilePath FilePath + | BP_RootNameDuplicate ModuleName.Raw FilePath FilePath + | BP_RootNameInvalid FilePath FilePath (List String) + | BP_CannotLoadDependencies + | BP_Cycle ModuleName.Raw (List ModuleName.Raw) + | BP_MissingExposed (NE.Nonempty ( ModuleName.Raw, Import.Problem )) + + +toBuildProblemReport : BuildProblem -> Help.Report +toBuildProblemReport problem = + case problem of + BuildBadModules root e es -> + Help.compilerReport root e es + + BuildProjectProblem projectProblem -> + toProjectProblemReport projectProblem + + +toProjectProblemReport : BuildProjectProblem -> Help.Report +toProjectProblemReport projectProblem = + case projectProblem of + BP_PathUnknown path -> + Help.report "FILE NOT FOUND" + Nothing + "I cannot find this file:" + [ D.indent 4 <| D.red <| D.fromChars path + , D.reflow <| "Is there a typo?" + , D.toSimpleNote <| + "If you are just getting started, try working through the examples in the official guide https://guide.elm-lang.org to get an idea of the kinds of things that typically go in a src/Main.elm file." + ] + + BP_WithBadExtension path -> + Help.report "UNEXPECTED FILE EXTENSION" + Nothing + "I can only compile Elm files (with a .elm extension) but you want me to compile:" + [ D.indent 4 <| D.red <| D.fromChars path + , D.reflow <| "Is there a typo? Can the file extension be changed?" + ] + + BP_WithAmbiguousSrcDir path srcDir1 srcDir2 -> + Help.report "CONFUSING FILE" + Nothing + "I am getting confused when I try to compile this file:" + [ D.indent 4 <| D.red <| D.fromChars path + , D.reflow <| + "I always check if files appear in any of the \"source-directories\" listed in your elm.json to see if there might be some cached information about them. That can help me compile faster! But in this case, it looks like this file may be in either of these directories:" + , D.indent 4 <| D.red <| D.vcat <| List.map D.fromChars [ srcDir1, srcDir2 ] + , D.reflow <| + "Try to make it so no source directory contains another source directory!" + ] + + BP_MainPathDuplicate path1 path2 -> + Help.report "CONFUSING FILES" + Nothing + "You are telling me to compile these two files:" + [ D.indent 4 <| D.red <| D.vcat <| List.map D.fromChars [ path1, path2 ] + , D.reflow <| + if path1 == path2 then + "Why are you telling me twice? Is something weird going on with a script? I figured I would let you know about it just in case something is wrong. Only list it once and you should be all set!" + + else + "But seem to be the same file though... It makes me think something tricky is going on with symlinks in your project, so I figured I would let you know about it just in case. Remove one of these files from your command to get unstuck!" + ] + + BP_RootNameDuplicate name outsidePath otherPath -> + Help.report "MODULE NAME CLASH" + Nothing + "These two files are causing a module name clash:" + [ D.indent 4 <| D.red <| D.vcat <| List.map D.fromChars [ outsidePath, otherPath ] + , D.reflow <| + "They both say `module " + ++ String.fromList (ModuleName.toChars name) + ++ " exposing (..)` up at the top, but they cannot have the same name!" + , D.reflow <| + "Try changing to a different module name in one of them!" + ] + + BP_RootNameInvalid givenPath srcDir _ -> + Help.report "UNEXPECTED FILE NAME" + Nothing + "I am having trouble with this file name:" + [ D.indent 4 <| D.red <| D.fromChars givenPath + , D.reflow <| + "I found it in your " + ++ Utils.fpAddTrailingPathSeparator srcDir + ++ " directory which is good, but I expect all of the files in there to use the following module naming convention:" + , toModuleNameConventionTable srcDir [ "Main", "HomePage", "Http.Helpers" ] + , D.reflow <| + "Notice that the names always start with capital letters! Can you make your file use this naming convention?" + , D.toSimpleNote <| + "Having a strict naming convention like this makes it a lot easier to find things in large projects. If you see a module imported, you know where to look for the corresponding file every time!" + ] + + BP_CannotLoadDependencies -> + corruptCacheReport + + BP_Cycle name names -> + Help.report "IMPORT CYCLE" + Nothing + "Your module imports form a cycle:" + [ D.cycle 4 name names + , D.reflow <| + "Learn more about why this is disallowed and how to break cycles here:" + ++ D.makeLink "import-cycles" + ] + + BP_MissingExposed (NE.Nonempty ( name, problem ) _) -> + case problem of + Import.NotFound -> + Help.report "MISSING MODULE" + (Just "elm.json") + "The \"exposed-modules\" of your elm.json lists the following module:" + [ D.indent 4 <| D.red <| D.fromName name + , D.reflow <| + "But I cannot find it in your src/ directory. Is there a typo? Was it renamed?" + ] + + Import.Ambiguous _ _ pkg _ -> + Help.report "AMBIGUOUS MODULE NAME" + (Just "elm.json") + "The \"exposed-modules\" of your elm.json lists the following module:" + [ D.indent 4 <| D.red <| D.fromName name + , D.reflow <| + "But a module from " + ++ Pkg.toChars pkg + ++ " already uses that name. Try choosing a different name for your local file." + ] + + Import.AmbiguousLocal path1 path2 paths -> + Help.report "AMBIGUOUS MODULE NAME" + (Just "elm.json") + "The \"exposed-modules\" of your elm.json lists the following module:" + [ D.indent 4 <| D.red <| D.fromName name + , D.reflow <| + "But I found multiple files with that name:" + , D.dullyellow <| + D.indent 4 <| + D.vcat <| + List.map D.fromChars (path1 :: path2 :: paths) + , D.reflow <| + "Change the module names to be distinct!" + ] + + Import.AmbiguousForeign _ _ _ -> + Help.report "MISSING MODULE" + (Just "elm.json") + "The \"exposed-modules\" of your elm.json lists the following module:" + [ D.indent 4 <| D.red <| D.fromName name + , D.reflow <| + "But I cannot find it in your src/ directory. Is there a typo? Was it renamed?" + , D.toSimpleNote <| + "It is not possible to \"re-export\" modules from other packages. You can only expose modules that you define in your own code." + ] + + +toModuleNameConventionTable : FilePath -> List String -> D.Doc +toModuleNameConventionTable srcDir names = + let + toPair : String -> ( String, FilePath ) + toPair name = + ( name + , Utils.fpCombine srcDir + (Utils.fpAddExtension + (String.map + (\c -> + if c == '.' then + Utils.fpPathSeparator + + else + c + ) + name + ) + "elm" + ) + ) + + namePairs : List ( String, FilePath ) + namePairs = + List.map toPair names + + nameWidth : Int + nameWidth = + Utils.listMaximum compare (11 :: List.map (String.length << Tuple.first) namePairs) + + pathWidth : Int + pathWidth = + Utils.listMaximum compare (9 :: List.map (String.length << Tuple.second) namePairs) + + padded : Int -> String -> String + padded width str = + str ++ String.repeat (width - String.length str) " " + + toRow : ( String, String ) -> D.Doc + toRow ( name, path ) = + D.fromChars <| + "| " + ++ padded nameWidth name + ++ " | " + ++ padded pathWidth path + ++ " |" + + bar : D.Doc + bar = + D.fromChars <| + "+-" + ++ String.repeat nameWidth "-" + ++ "-+-" + ++ String.repeat pathWidth "-" + ++ "-+" + in + D.indent 4 <| + D.vcat <| + [ bar, toRow ( "Module Name", "File Path" ), bar ] + ++ List.map toRow namePairs + ++ [ bar ] + + + +-- GENERATE + + +type Generate + = GenerateCannotLoadArtifacts + | GenerateCannotOptimizeDebugValues ModuleName.Raw (List ModuleName.Raw) + + +toGenerateReport : Generate -> Help.Report +toGenerateReport problem = + case problem of + GenerateCannotLoadArtifacts -> + corruptCacheReport + + GenerateCannotOptimizeDebugValues m ms -> + Help.report "DEBUG REMNANTS" + Nothing + "There are uses of the `Debug` module in the following modules:" + [ D.indent 4 <| D.red <| D.vcat <| List.map (D.fromChars << String.fromList << ModuleName.toChars) (m :: ms) + , D.reflow "But the --optimize flag only works if all `Debug` functions are removed!" + , D.toSimpleNote <| + "The issue is that --optimize strips out info needed by `Debug` functions. Here are two examples:" + , D.indent 4 <| + D.reflow <| + "(1) It shortens record field names. This makes the generated JavaScript smaller, but `Debug.toString` cannot know the real field names anymore." + , D.indent 4 <| + D.reflow <| + "(2) Values like `type Height = Height Float` are unboxed. This reduces allocation, but it also means that `Debug.toString` cannot tell if it is looking at a `Height` or `Float` value." + , D.reflow <| + "There are a few other cases like that, and it will be much worse once we start inlining code. That optimization could move `Debug.log` and `Debug.todo` calls, resulting in unpredictable behavior. I hope that clarifies why this restriction exists!" + ] + + + +-- CORRUPT CACHE + + +corruptCacheReport : Help.Report +corruptCacheReport = + Help.report "CORRUPT CACHE" + Nothing + "It looks like some of the information cached in guida-stuff/ has been corrupted." + [ D.reflow <| + "Try deleting your guida-stuff/ directory to get unstuck." + , D.toSimpleNote <| + "This almost certainly means that a 3rd party tool (or editor plugin) is causing problems to the guida-stuff/ directory. Try disabling 3rd party tools one by one until you figure out which it is!" + ] + + + +-- REPL + + +type Repl + = ReplBadDetails Details + | ReplBadInput String Error.Error + | ReplBadLocalDeps FilePath Error.Module (List Error.Module) + | ReplProjectProblem BuildProjectProblem + | ReplBadGenerate Generate + | ReplBadCache + | ReplBlocked + + +replToReport : Repl -> Help.Report +replToReport problem = + case problem of + ReplBadDetails details -> + toDetailsReport details + + ReplBadInput source err -> + Help.compilerReport "/" (Error.Module N.replModule "REPL" File.zeroTime source err) [] + + ReplBadLocalDeps root e es -> + Help.compilerReport root e es + + ReplProjectProblem projectProblem -> + toProjectProblemReport projectProblem + + ReplBadGenerate generate -> + toGenerateReport generate + + ReplBadCache -> + corruptCacheReport + + ReplBlocked -> + corruptCacheReport + + + +-- TEST + + +type Test + = TestNoOutline + | TestBadOutline Outline + | TestBadRegistry RegistryProblem + | TestNoOnlineAppSolution Pkg.Name + | TestNoOfflineAppSolution Pkg.Name + | TestNoOnlinePkgSolution Pkg.Name + | TestNoOfflinePkgSolution Pkg.Name + | TestHadSolverTrouble Solver + | TestUnknownPackageOnline Pkg.Name (List Pkg.Name) + | TestUnknownPackageOffline Pkg.Name (List Pkg.Name) + | TestBadDetails Details + | TestCannotBuild BuildProblem + | TestBadGenerate Generate + + +testToReport : Test -> Help.Report +testToReport test = + case test of + TestNoOutline -> + Help.report "TEST WHAT?" + Nothing + "I cannot find an elm.json so I am not sure what you want me to test." + [ D.reflow <| + "Elm packages always have an elm.json that states the version number, dependencies, exposed modules, etc." + ] + + TestBadOutline outline -> + toOutlineReport outline + + TestBadRegistry problem -> + toRegistryProblemReport "PROBLEM LOADING PACKAGE LIST" problem <| + "I need the list of published packages to figure out how to install things" + + TestNoOnlineAppSolution pkg -> + Help.report "CANNOT FIND COMPATIBLE VERSION" + (Just "elm.json") + ("I cannot find a version of " ++ Pkg.toChars pkg ++ " that is compatible with your existing dependencies.") + [ D.reflow <| + "I checked all the published versions. When that failed, I tried to find any compatible combination of these packages, even if it meant changing all your existing dependencies! That did not work either!" + , D.reflow <| + "This is most likely to happen when a package is not upgraded yet. Maybe a new version of Elm came out recently? Maybe a common package was changed recently? Maybe a better package came along, so there was no need to upgrade this one? Try asking around https://elm-lang.org/community to learn what might be going on with this package." + , D.toSimpleNote <| + "Whatever the case, please be kind to the relevant package authors! Having friendly interactions with users is great motivation, and conversely, getting berated by strangers on the internet sucks your soul dry. Furthermore, package authors are humans with families, friends, jobs, vacations, responsibilities, goals, etc. They face obstacles outside of their technical work you will never know about, so please assume the best and try to be patient and supportive!" + ] + + TestNoOfflineAppSolution pkg -> + Help.report "CANNOT FIND COMPATIBLE VERSION LOCALLY" + (Just "elm.json") + ("I cannot find a version of " ++ Pkg.toChars pkg ++ " that is compatible with your existing dependencies.") + [ D.reflow <| + "I was not able to connect to https://package.elm-lang.org/ though, so I was only able to look through packages that you have downloaded in the past." + , D.reflow <| + "Try again later when you have internet!" + ] + + TestNoOnlinePkgSolution pkg -> + Help.report "CANNOT FIND COMPATIBLE VERSION" + (Just "elm.json") + ("I cannot find a version of " ++ Pkg.toChars pkg ++ " that is compatible with your existing constraints.") + [ D.reflow <| + "With applications, I try to broaden the constraints to see if anything works, but messing with package constraints is much more delicate business. E.g. making your constraints stricter may make it harder for applications to find compatible dependencies. So fixing something here may break it for a lot of other people!" + , D.reflow <| + "So I recommend making an application with the same dependencies as your package. See if there is a solution at all. From there it may be easier to figure out how to proceed in a way that will disrupt your users as little as possible. And the solution may be to help other package authors to get their packages updated, or to drop a dependency entirely." + ] + + TestNoOfflinePkgSolution pkg -> + Help.report "CANNOT FIND COMPATIBLE VERSION LOCALLY" + (Just "elm.json") + ("I cannot find a version of " ++ Pkg.toChars pkg ++ " that is compatible with your existing constraints.") + [ D.reflow <| + "I was not able to connect to https://package.elm-lang.org/ though, so I was only able to look through packages that you have downloaded in the past." + , D.reflow <| + "Try again later when you have internet!" + ] + + TestHadSolverTrouble solver -> + toSolverReport solver + + TestUnknownPackageOnline pkg suggestions -> + Help.docReport "UNKNOWN PACKAGE" + Nothing + (D.fillSep + [ D.fromChars "I" + , D.fromChars "cannot" + , D.fromChars "find" + , D.fromChars "a" + , D.fromChars "package" + , D.fromChars "named" + , D.red (D.fromPackage pkg) + |> D.a (D.fromChars ".") + ] + ) + [ D.reflow <| + "I looked through https://package.elm-lang.org for packages with similar names and found these:" + , D.indent 4 <| D.dullyellow <| D.vcat <| List.map D.fromPackage suggestions + , D.reflow <| "Maybe you want one of these instead?" + ] + + TestUnknownPackageOffline pkg suggestions -> + Help.docReport "UNKNOWN PACKAGE" + Nothing + (D.fillSep + [ D.fromChars "I" + , D.fromChars "cannot" + , D.fromChars "find" + , D.fromChars "a" + , D.fromChars "package" + , D.fromChars "named" + , D.red (D.fromPackage pkg) + |> D.a (D.fromChars ".") + ] + ) + [ D.reflow <| + "I could not connect to https://package.elm-lang.org though, so new packages may have been published since I last updated my local cache of package names." + , D.reflow <| + "Looking through the locally cached names, the closest ones are:" + , D.indent 4 <| D.dullyellow <| D.vcat <| List.map D.fromPackage suggestions + , D.reflow <| "Maybe you want one of these instead?" + ] + + TestBadDetails details -> + toDetailsReport details + + TestCannotBuild buildProblem -> + toBuildProblemReport buildProblem + + TestBadGenerate generateProblem -> + toGenerateReport generateProblem + + + +-- ENCODERS and DECODERS + + +detailsBadDepEncoder : DetailsBadDep -> BE.Encoder +detailsBadDepEncoder detailsBadDep = + case detailsBadDep of + BD_BadDownload pkg vsn packageProblem -> + BE.sequence + [ BE.unsignedInt8 0 + , Pkg.nameEncoder pkg + , V.versionEncoder vsn + , packageProblemEncoder packageProblem + ] + + BD_BadBuild pkg vsn fingerprint -> + BE.sequence + [ BE.unsignedInt8 1 + , Pkg.nameEncoder pkg + , V.versionEncoder vsn + , BE.assocListDict compare Pkg.nameEncoder V.versionEncoder fingerprint + ] + + +detailsBadDepDecoder : BD.Decoder DetailsBadDep +detailsBadDepDecoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.map3 BD_BadDownload + Pkg.nameDecoder + V.versionDecoder + packageProblemDecoder + + 1 -> + BD.map3 BD_BadBuild + Pkg.nameDecoder + V.versionDecoder + (BD.assocListDict identity Pkg.nameDecoder V.versionDecoder) + + _ -> + BD.fail + ) + + +buildProblemEncoder : BuildProblem -> BE.Encoder +buildProblemEncoder buildProblem = + case buildProblem of + BuildBadModules root e es -> + BE.sequence + [ BE.unsignedInt8 0 + , BE.string root + , Error.moduleEncoder e + , BE.list Error.moduleEncoder es + ] + + BuildProjectProblem problem -> + BE.sequence + [ BE.unsignedInt8 1 + , buildProjectProblemEncoder problem + ] + + +buildProblemDecoder : BD.Decoder BuildProblem +buildProblemDecoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.map3 BuildBadModules + BD.string + Error.moduleDecoder + (BD.list Error.moduleDecoder) + + 1 -> + BD.map BuildProjectProblem buildProjectProblemDecoder + + _ -> + BD.fail + ) + + +buildProjectProblemEncoder : BuildProjectProblem -> BE.Encoder +buildProjectProblemEncoder buildProjectProblem = + case buildProjectProblem of + BP_PathUnknown path -> + BE.sequence + [ BE.unsignedInt8 0 + , BE.string path + ] + + BP_WithBadExtension path -> + BE.sequence + [ BE.unsignedInt8 1 + , BE.string path + ] + + BP_WithAmbiguousSrcDir path srcDir1 srcDir2 -> + BE.sequence + [ BE.unsignedInt8 2 + , BE.string path + , BE.string srcDir1 + , BE.string srcDir2 + ] + + BP_MainPathDuplicate path1 path2 -> + BE.sequence + [ BE.unsignedInt8 3 + , BE.string path1 + , BE.string path2 + ] + + BP_RootNameDuplicate name outsidePath otherPath -> + BE.sequence + [ BE.unsignedInt8 4 + , ModuleName.rawEncoder name + , BE.string outsidePath + , BE.string otherPath + ] + + BP_RootNameInvalid givenPath srcDir names -> + BE.sequence + [ BE.unsignedInt8 5 + , BE.string givenPath + , BE.string srcDir + , BE.list BE.string names + ] + + BP_CannotLoadDependencies -> + BE.unsignedInt8 6 + + BP_Cycle name names -> + BE.sequence + [ BE.unsignedInt8 7 + , ModuleName.rawEncoder name + , BE.list ModuleName.rawEncoder names + ] + + BP_MissingExposed problems -> + BE.sequence + [ BE.unsignedInt8 8 + , BE.nonempty (BE.jsonPair ModuleName.rawEncoder Import.problemEncoder) problems + ] + + +buildProjectProblemDecoder : BD.Decoder BuildProjectProblem +buildProjectProblemDecoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.map BP_PathUnknown BD.string + + 1 -> + BD.map BP_WithBadExtension BD.string + + 2 -> + BD.map3 BP_WithAmbiguousSrcDir + BD.string + BD.string + BD.string + + 3 -> + BD.map2 BP_MainPathDuplicate + BD.string + BD.string + + 4 -> + BD.map3 BP_RootNameDuplicate + ModuleName.rawDecoder + BD.string + BD.string + + 5 -> + BD.map3 BP_RootNameInvalid + BD.string + BD.string + (BD.list BD.string) + + 6 -> + BD.succeed BP_CannotLoadDependencies + + 7 -> + BD.map2 BP_Cycle + ModuleName.rawDecoder + (BD.list ModuleName.rawDecoder) + + 8 -> + BD.map BP_MissingExposed + (BD.nonempty + (BD.jsonPair ModuleName.rawDecoder Import.problemDecoder) + ) + + _ -> + BD.fail + ) + + +registryProblemEncoder : RegistryProblem -> BE.Encoder +registryProblemEncoder registryProblem = + case registryProblem of + RP_Http err -> + BE.sequence + [ BE.unsignedInt8 0 + , Http.errorEncoder err + ] + + RP_Data url body -> + BE.sequence + [ BE.unsignedInt8 1 + , BE.string url + , BE.string body + ] + + +registryProblemDecoder : BD.Decoder RegistryProblem +registryProblemDecoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.map RP_Http Http.errorDecoder + + 1 -> + BD.map2 RP_Data + BD.string + BD.string + + _ -> + BD.fail + ) + + +packageProblemEncoder : PackageProblem -> BE.Encoder +packageProblemEncoder packageProblem = + case packageProblem of + PP_BadEndpointRequest httpError -> + BE.sequence + [ BE.unsignedInt8 0 + , Http.errorEncoder httpError + ] + + PP_BadEndpointContent url -> + BE.sequence + [ BE.unsignedInt8 1 + , BE.string url + ] + + PP_BadArchiveRequest httpError -> + BE.sequence + [ BE.unsignedInt8 2 + , Http.errorEncoder httpError + ] + + PP_BadArchiveContent url -> + BE.sequence + [ BE.unsignedInt8 3 + , BE.string url + ] + + PP_BadArchiveHash url expectedHash actualHash -> + BE.sequence + [ BE.unsignedInt8 4 + , BE.string url + , BE.string expectedHash + , BE.string actualHash + ] + + +packageProblemDecoder : BD.Decoder PackageProblem +packageProblemDecoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.map PP_BadEndpointRequest Http.errorDecoder + + 1 -> + BD.map PP_BadEndpointContent BD.string + + 2 -> + BD.map PP_BadArchiveRequest Http.errorDecoder + + 3 -> + BD.map PP_BadArchiveContent BD.string + + 4 -> + BD.map3 PP_BadArchiveHash + BD.string + BD.string + BD.string + + _ -> + BD.fail + ) diff --git a/src/Builder/Reporting/Exit/Help.elm b/src/Builder/Reporting/Exit/Help.elm new file mode 100644 index 0000000000..0b7953fd8a --- /dev/null +++ b/src/Builder/Reporting/Exit/Help.elm @@ -0,0 +1,140 @@ +module Builder.Reporting.Exit.Help exposing + ( Report + , compilerReport + , docReport + , jsonReport + , report + , reportToDoc + , reportToJson + , toStderr + , toStdout + ) + +import Compiler.Json.Encode as E +import Compiler.Reporting.Doc as D +import Compiler.Reporting.Error as Error +import Maybe.Extra as Maybe +import System.IO as IO +import Task exposing (Task) +import Utils.Task.Extra as Task + + + +-- REPORT + + +type Report + = CompilerReport String Error.Module (List Error.Module) + | Report String (Maybe String) D.Doc + + +report : String -> Maybe String -> String -> List D.Doc -> Report +report title path startString others = + Report title path <| D.stack (D.reflow startString :: others) + + +docReport : String -> Maybe String -> D.Doc -> List D.Doc -> Report +docReport title path startDoc others = + Report title path <| D.stack (startDoc :: others) + + +jsonReport : String -> Maybe String -> D.Doc -> Report +jsonReport = + Report + + +compilerReport : String -> Error.Module -> List Error.Module -> Report +compilerReport = + CompilerReport + + + +-- TO DOC + + +reportToDoc : Report -> D.Doc +reportToDoc report_ = + case report_ of + CompilerReport root e es -> + Error.toDoc root e es + + Report title maybePath message -> + let + makeDashes : Int -> String + makeDashes n = + String.repeat (max 1 (80 - n)) "-" + + errorBarEnd : String + errorBarEnd = + case maybePath of + Nothing -> + makeDashes (4 + String.length title) + + Just path -> + makeDashes (5 + String.length title + String.length path) + ++ " " + ++ path + + errorBar : D.Doc + errorBar = + D.dullcyan + (D.fromChars "--" + |> D.plus (D.fromChars title) + |> D.plus (D.fromChars errorBarEnd) + ) + in + D.stack [ errorBar, message, D.fromChars "" ] + + + +-- TO JSON + + +reportToJson : Report -> E.Value +reportToJson report_ = + case report_ of + CompilerReport _ e es -> + E.object + [ ( "type", E.string "compile-errors" ) + , ( "errors", E.list Error.toJson (e :: es) ) + ] + + Report title maybePath message -> + E.object + [ ( "type", E.string "error" ) + , ( "path", Maybe.unwrap E.null E.string maybePath ) + , ( "title", E.string title ) + , ( "message", D.encode message ) + ] + + + +-- OUTPUT + + +toString : D.Doc -> String +toString = + D.toString + + +toStdout : D.Doc -> Task Never () +toStdout doc = + toHandle IO.stdout doc + + +toStderr : D.Doc -> Task Never () +toStderr doc = + toHandle IO.stderr doc + + +toHandle : IO.Handle -> D.Doc -> Task Never () +toHandle handle doc = + IO.hIsTerminalDevice handle + |> Task.bind + (\isTerminal -> + if isTerminal then + D.toAnsi handle doc + + else + IO.hPutStr handle (toString doc) + ) diff --git a/src/Builder/Stuff.elm b/src/Builder/Stuff.elm new file mode 100644 index 0000000000..9728ecd4b8 --- /dev/null +++ b/src/Builder/Stuff.elm @@ -0,0 +1,217 @@ +module Builder.Stuff exposing + ( PackageCache + , details + , findRoot + , getElmHome + , getPackageCache + , getReplCache + , guidai + , guidao + , interfaces + , objects + , package + , packageCacheDecoder + , packageCacheEncoder + , prepublishDir + , registry + , testDir + , withRegistryLock + , withRootLock + ) + +import Compiler.Elm.ModuleName as ModuleName +import Compiler.Elm.Package as Pkg +import Compiler.Elm.Version as V +import Prelude +import Task exposing (Task) +import Utils.Bytes.Decode as BD +import Utils.Bytes.Encode as BE +import Utils.Main as Utils +import Utils.Task.Extra as Task + + + +-- PATHS + + +stuff : String -> String +stuff root = + root ++ "/guida-stuff/" ++ compilerVersion + + +details : String -> String +details root = + stuff root ++ "/d.dat" + + +interfaces : String -> String +interfaces root = + stuff root ++ "/i.dat" + + +objects : String -> String +objects root = + stuff root ++ "/o.dat" + + +prepublishDir : String -> String +prepublishDir root = + stuff root ++ "/prepublish" + + +testDir : String -> String +testDir root = + stuff root ++ "/test" + + +compilerVersion : String +compilerVersion = + V.toChars V.compiler + + + +-- ELMI and ELMO + + +guidai : String -> ModuleName.Raw -> String +guidai root name = + toArtifactPath root name "guidai" + + +guidao : String -> ModuleName.Raw -> String +guidao root name = + toArtifactPath root name "guidao" + + +toArtifactPath : String -> ModuleName.Raw -> String -> String +toArtifactPath root name ext = + Utils.fpCombine (stuff root) (Utils.fpAddExtension (ModuleName.toHyphenPath name) ext) + + + +-- ROOT + + +findRoot : Task Never (Maybe String) +findRoot = + Utils.dirGetCurrentDirectory + |> Task.bind + (\dir -> + findRootHelp (Utils.fpSplitDirectories dir) + ) + + +findRootHelp : List String -> Task Never (Maybe String) +findRootHelp dirs = + case dirs of + [] -> + Task.pure Nothing + + _ :: _ -> + Utils.dirDoesFileExist (Utils.fpJoinPath dirs ++ "/elm.json") + |> Task.bind + (\exists -> + if exists then + Task.pure (Just (Utils.fpJoinPath dirs)) + + else + findRootHelp (Prelude.init dirs) + ) + + + +-- LOCKS + + +withRootLock : String -> Task Never a -> Task Never a +withRootLock root work = + let + dir : String + dir = + stuff root + in + Utils.dirCreateDirectoryIfMissing True dir + |> Task.bind + (\_ -> + Utils.lockWithFileLock (dir ++ "/lock") Utils.LockExclusive (\_ -> work) + ) + + +withRegistryLock : PackageCache -> Task Never a -> Task Never a +withRegistryLock (PackageCache dir) work = + Utils.lockWithFileLock (dir ++ "/lock") Utils.LockExclusive (\_ -> work) + + + +-- PACKAGE CACHES + + +type PackageCache + = PackageCache String + + +getPackageCache : Task Never PackageCache +getPackageCache = + Task.fmap PackageCache (getCacheDir "packages") + + +registry : PackageCache -> String +registry (PackageCache dir) = + Utils.fpCombine dir "registry.dat" + + +package : PackageCache -> Pkg.Name -> V.Version -> String +package (PackageCache dir) name version = + Utils.fpCombine dir (Utils.fpCombine (Pkg.toString name) (V.toChars version)) + + + +-- CACHE + + +getReplCache : Task Never String +getReplCache = + getCacheDir "repl" + + +getCacheDir : String -> Task Never String +getCacheDir projectName = + getElmHome + |> Task.bind + (\home -> + let + root : Utils.FilePath + root = + Utils.fpCombine home (Utils.fpCombine compilerVersion projectName) + in + Utils.dirCreateDirectoryIfMissing True root + |> Task.fmap (\_ -> root) + ) + + +getElmHome : Task Never String +getElmHome = + Utils.envLookupEnv "GUIDA_HOME" + |> Task.bind + (\maybeCustomHome -> + case maybeCustomHome of + Just customHome -> + Task.pure customHome + + Nothing -> + Utils.dirGetAppUserDataDirectory "guida" + ) + + + +-- ENCODERS and DECODERS + + +packageCacheEncoder : PackageCache -> BE.Encoder +packageCacheEncoder (PackageCache dir) = + BE.string dir + + +packageCacheDecoder : BD.Decoder PackageCache +packageCacheDecoder = + BD.map PackageCache BD.string diff --git a/src/Codec/Archive/Zip.elm b/src/Codec/Archive/Zip.elm new file mode 100644 index 0000000000..3ded51575f --- /dev/null +++ b/src/Codec/Archive/Zip.elm @@ -0,0 +1,46 @@ +module Codec.Archive.Zip exposing + ( Archive + , Entry + , FilePath + , eRelativePath + , fromEntry + , zEntries + ) + +{-| The module provides everything you may need to manipulate Zip archives. +There are three things that should be clarified right away, to avoid confusion. + +Ref.: + +-} + + +{-| FIXME System.IO.FilePath +-} +type alias FilePath = + String + + +type alias Archive = + List Entry + + +type alias Entry = + { eRelativePath : FilePath + , eData : String + } + + +zEntries : Archive -> List Entry +zEntries = + identity + + +eRelativePath : Entry -> FilePath +eRelativePath zipEntry = + zipEntry.eRelativePath + + +fromEntry : Entry -> String +fromEntry zipEntry = + zipEntry.eData diff --git a/src/Common/Format.elm b/src/Common/Format.elm new file mode 100644 index 0000000000..03cb5fc04c --- /dev/null +++ b/src/Common/Format.elm @@ -0,0 +1,19 @@ +module Common.Format exposing (format) + +import Common.Format.Box as Box +import Common.Format.Render.Box as Render +import Compiler.Parse.Module as M +import Compiler.Parse.Primitives as P +import Compiler.Parse.SyntaxVersion exposing (SyntaxVersion) +import Compiler.Reporting.Error.Syntax as E + + +format : SyntaxVersion -> M.ProjectType -> String -> Result E.Module String +format syntaxVersion projectType src = + P.fromByteString (M.chompModule syntaxVersion projectType) E.ModuleBadEnd src + |> Result.map render + + +render : M.Module -> String +render modu = + Box.render (Render.formatModule True 2 modu) ++ "\n" diff --git a/src/Common/Format/Bimap.elm b/src/Common/Format/Bimap.elm new file mode 100644 index 0000000000..78338a9011 --- /dev/null +++ b/src/Common/Format/Bimap.elm @@ -0,0 +1,16 @@ +module Common.Format.Bimap exposing + ( Bimap + , fromList + ) + +import Data.Map as Map exposing (Dict) + + +type Bimap a b + = Bimap (Dict String a b) (Dict String b a) + + +fromList : (a -> String) -> (b -> String) -> List ( a, b ) -> Bimap a b +fromList toComparableA toComparableB list = + Bimap (Map.fromList toComparableA list) + (Map.fromList toComparableB (List.map (\( a, b ) -> ( b, a )) list)) diff --git a/src/Common/Format/Box.elm b/src/Common/Format/Box.elm new file mode 100644 index 0000000000..9db30bac35 --- /dev/null +++ b/src/Common/Format/Box.elm @@ -0,0 +1,387 @@ +module Common.Format.Box exposing + ( Line, identifier, keyword, punc, literal, row, space + , Box(..), blankLine, line, mustBreak, stack_, stack1, andThen + , isLine, allSingles, lineLength + , indent, prefix, addSuffix + , render + ) + +{-| Ref.: `elm-format-lib/src/Box.hs` + +@docs Line, identifier, keyword, punc, literal, row, space +@docs Box, blankLine, line, mustBreak, stack_, stack1, andThen +@docs isLine, allSingles, lineLength +@docs indent, prefix, addSuffix +@docs render + +-} + +import Basics.Extra exposing (flip) +import Prelude +import Result.Extra as Result +import Utils.Crash exposing (crash) +import Utils.Main as Utils + + +{-| A line is ALWAYS just one line. + +Space is self-explanatory, +Tab aligns to the nearest multiple of 4 spaces, +Text brings any string into the data structure, +Row joins more of these elements onto one line. + +-} +type Line + = Text String + | Row (List Line) + | Space + | Tab + + +identifier : String -> Line +identifier = + Text + + +keyword : String -> Line +keyword = + Text + + +punc : String -> Line +punc = + Text + + +literal : String -> Line +literal = + Text + + +{-| join more Line elements into one +-} +row : List Line -> Line +row = + Row + + +space : Line +space = + Space + + +{-| Box contains Lines (at least one - can't be empty). +Box either: + + - can appear in the middle of a line + (Stack someLine [], thus can be joined without problems), or + - has to appear on its own + (Stack someLine moreLines OR MustBreak someLine). + +MustBreak is only used for `--` comments. + +Stack contains two or more lines. + +Sometimes (see `prefix`) the first line of Stack +gets different treatment than the other lines. + +-} +type Box + = SingleLine Line + | Stack Line Line (List Line) + | MustBreak Line + + +{-| -} +blankLine : Box +blankLine = + line (literal "") + + +{-| -} +line : Line -> Box +line l = + SingleLine l + + +{-| -} +mustBreak : Line -> Box +mustBreak l = + MustBreak l + + +{-| -} +stack_ : Box -> Box -> Box +stack_ b1 b2 = + let + ( line1first, line1rest ) = + destructure b1 + + ( line2first, line2rest ) = + destructure b2 + in + case line1rest ++ line2first :: line2rest of + [] -> + crash "the list will contain at least line2first" + + first :: rest -> + Stack line1first first rest + + +{-| -} +andThen : List Box -> Box -> Box +andThen rest first = + List.foldl (flip stack_) first rest + + +{-| -} +stack1 : List Box -> Box +stack1 children = + case children of + [] -> + crash "stack1: empty structure" + + [ first ] -> + first + + boxes -> + Utils.foldr1 stack_ boxes + + +mapLines : (Line -> Line) -> Box -> Box +mapLines fn = + mapFirstLine fn fn + + +mapFirstLine : (Line -> Line) -> (Line -> Line) -> Box -> Box +mapFirstLine firstFn restFn b = + case b of + SingleLine l1 -> + SingleLine (firstFn l1) + + Stack l1 l2 ls -> + Stack (firstFn l1) (restFn l2) (List.map restFn ls) + + MustBreak l1 -> + MustBreak (firstFn l1) + + +indent : Box -> Box +indent = + mapLines (\l -> row [ Tab, l ]) + + +isLine : Box -> Result Box Line +isLine b = + case b of + SingleLine l -> + Ok l + + _ -> + Err b + + +destructure : Box -> ( Line, List Line ) +destructure b = + case b of + SingleLine l1 -> + ( l1, [] ) + + Stack l1 l2 rest -> + ( l1, l2 :: rest ) + + MustBreak l1 -> + ( l1, [] ) + + +allSingles : List Box -> Result (List Box) (List Line) +allSingles boxes = + case Result.combine (List.map isLine boxes) of + Ok lines_ -> + Ok lines_ + + _ -> + Err boxes + + +{-| Add the prefix to the first line, +pad the other lines with spaces of the same length + +EXAMPLE: +abcde +xyz +-----> +myPrefix abcde +xyz + +-} +prefix : Line -> Box -> Box +prefix pref = + let + prefixLength : Int + prefixLength = + lineLength 0 pref + + paddingSpaces : List Line + paddingSpaces = + List.repeat prefixLength space + + padLineWithSpaces : Line -> Line + padLineWithSpaces l = + row [ row paddingSpaces, l ] + + addPrefixToLine : Line -> Line + addPrefixToLine l = + row [ pref, l ] + in + mapFirstLine addPrefixToLine padLineWithSpaces + + +addSuffix : Line -> Box -> Box +addSuffix suffix b = + case destructure b of + ( l, [] ) -> + line (row [ l, suffix ]) + + ( l1, ls ) -> + line l1 + |> andThen (List.map line (Prelude.init ls)) + |> andThen [ line (row [ Prelude.last ls, suffix ]) ] + + +renderLine : Int -> Line -> String +renderLine startColumn line_ = + case line_ of + Text text -> + text + + Space -> + " " + + Tab -> + String.fromList (List.repeat (tabLength startColumn) ' ') + + Row lines_ -> + renderRow startColumn lines_ + + +render : Box -> String +render box = + case box of + SingleLine line_ -> + String.trimRight (renderLine 0 line_) ++ "\n" + + Stack l1 l2 rest -> + String.join "\n" (List.map (String.trimRight << renderLine 0) (l1 :: l2 :: rest)) + + MustBreak line_ -> + String.trimRight (renderLine 0 line_) ++ "\n" + + +lineLength : Int -> Line -> Int +lineLength startColumn line_ = + startColumn + + (case line_ of + Text string -> + String.length string + + Space -> + 1 + + Tab -> + tabLength startColumn + + Row lines_ -> + rowLength startColumn lines_ + ) + + +initRow : Int -> ( String, Int ) +initRow startColumn = + ( "", startColumn ) + + +spacesInTab : Int +spacesInTab = + 4 + + +spacesToNextTab : Int -> Int +spacesToNextTab startColumn = + modBy spacesInTab startColumn + + +tabLength : Int -> Int +tabLength startColumn = + spacesInTab - spacesToNextTab startColumn + + +{-| What happens here is we take a row and start building its contents +along with the resulting length of the string. We need to have that +because of Tabs, which need to be passed the current column in arguments +in order to determine how many Spaces are they going to span. +(See `tabLength`.) + +So for example if we have a Box [Space, Tab, Text "abc", Tab, Text "x"], +it goes like this: + +string | column | todo +"" | 0 | [Space, Tab, Text "abc", Tab, Text "x"] +" " | 1 | [Tab, Text "abc", Tab, Text "x"] +" " | 4 | [Text "abc", Tab, Text "x"] +" abc" | 7 | [Tab, Text "x"] +" abc " | 8 | [Text "x"] +" abc x" | 9 | [] + +Thus we get the result string with correctly rendered Tabs. + +The (String, Int) type here means the (string, column) from the table above. + +Then we just need to do one final modification to get from endColumn to resultLength, +which is what we are after in the function `rowLength`. + +-} +renderRow_ : Int -> List Line -> ( String, Int ) +renderRow_ startColumn lines_ = + let + ( result, endColumn ) = + List.foldl addLine (initRow startColumn) lines_ + + resultLength : Int + resultLength = + endColumn - startColumn + in + ( result, resultLength ) + + +{-| A step function for renderRow\_. + + addLine Tab ( " ", 1 ) == ( " ", 4 ) + +-} +addLine : Line -> ( String, Int ) -> ( String, Int ) +addLine line_ ( string, startColumn_ ) = + let + newString : String + newString = + string ++ renderLine startColumn_ line_ + + newStartColumn : Int + newStartColumn = + lineLength startColumn_ line_ + in + ( newString, newStartColumn ) + + +{-| Extract the final string from renderRow\_ +-} +renderRow : Int -> List Line -> String +renderRow startColumn lines_ = + Tuple.first (renderRow_ startColumn lines_) + + +{-| Extract the final length from renderRow\_ +-} +rowLength : Int -> List Line -> Int +rowLength startColumn lines_ = + Tuple.second (renderRow_ startColumn lines_) diff --git a/src/Common/Format/Cheapskate/Inlines.elm b/src/Common/Format/Cheapskate/Inlines.elm new file mode 100644 index 0000000000..98b28098f6 --- /dev/null +++ b/src/Common/Format/Cheapskate/Inlines.elm @@ -0,0 +1,981 @@ +module Common.Format.Cheapskate.Inlines exposing + ( pHtmlTag + , pLinkLabel + , pReference + , parseInlines + ) + +import Common.Format.Cheapskate.ParserCombinators exposing (Parser, anyChar, bind, char, endOfInput, fail, fmap, guard, lazy, leftSequence, many, manyTill, mzero, notAfter, notInClass, oneOf, option, parse, peekChar, return, satisfy, scan, showParseError, skip, string, takeTill, takeWhile, takeWhile1) +import Common.Format.Cheapskate.Types exposing (HtmlTagType(..), Inline(..), Inlines, LinkTarget(..), ReferenceMap) +import Common.Format.Cheapskate.Util exposing (isEscapable, isWhitespace, nfb, nfbChar, scanSpaces, scanSpnl) +import Set exposing (Set) +import Utils.Crash exposing (crash) + + +{-| Returns tag type and whole tag. +-} +pHtmlTag : Parser ( HtmlTagType, String ) +pHtmlTag = + char '<' + |> bind + (\_ -> + -- do not end the tag with a > character in a quoted attribute. + oneOf (char '/' |> fmap (\_ -> True)) (return False) + |> bind + (\closing -> + takeWhile1 (\c -> isAsciiAlphaNum c || c == '?' || c == '!') + |> bind + (\tagname -> + let + tagname_ : String + tagname_ = + String.toLower tagname + + attr : Parser String + attr = + takeWhile isSpace + |> bind + (\ss -> + satisfy Char.isAlpha + |> bind + (\x -> + takeWhile (\c -> isAsciiAlphaNum c || c == ':') + |> bind + (\xs -> + skip ((==) '=') + |> bind (\_ -> oneOf (pQuoted '"') (oneOf (pQuoted '\'') (oneOf (takeWhile1 Char.isAlphaNum) (return "")))) + |> fmap + (\v -> + ss ++ String.fromChar x ++ xs ++ "=" ++ v + ) + ) + ) + ) + in + many attr + |> fmap String.concat + |> bind + (\attrs -> + takeWhile (\c -> isSpace c || c == '/') + |> bind + (\final -> + char '>' + |> bind + (\_ -> + let + tagtype : HtmlTagType + tagtype = + if closing then + Closing tagname_ + + else + case stringStripSuffix "/" final of + Just _ -> + SelfClosing tagname_ + + Nothing -> + Opening tagname_ + in + return + ( tagtype + , String.fromList + ('<' + :: (if closing then + [ '/' ] + + else + [] + ) + ) + ++ tagname + ++ attrs + ++ final + ++ ">" + ) + ) + ) + ) + ) + ) + ) + + +isSpace : Char -> Bool +isSpace c = + c == '\t' || c == '\n' || c == '\u{000D}' + + +stringStripSuffix : String -> String -> Maybe String +stringStripSuffix p t = + if String.endsWith p t then + Just (String.dropRight (String.length p) t) + + else + Nothing + + +{-| Parses a quoted attribute value. +-} +pQuoted : Char -> Parser String +pQuoted c = + skip ((==) c) + |> bind (\_ -> takeTill ((==) c)) + |> bind + (\contents -> + skip ((==) c) + |> fmap (\_ -> String.fromChar c ++ contents ++ String.fromChar c) + ) + + +{-| Parses an HTML comment. This isn't really correct to spec, but should +do for now. +-} +pHtmlComment : Parser String +pHtmlComment = + string "")) + |> bind (\rest -> return ("")) + + +{-| A link label [like this]. Note the precedence: code backticks have +precedence over label bracket markers, which have precedence over +\*, \_, and other inline formatting markers. +So, 2 below contains a link while 1 does not: + +1. [a link `with a ](/url)` character +2. [a link \*with emphasized ](/url) text\* + +-} +pLinkLabel : Parser String +pLinkLabel = + let + regChunk : Parser String + regChunk = + takeWhile1 (\c -> c /= '`' && c /= '[' && c /= ']' && c /= '\\') + + codeChunk : Parser String + codeChunk = + fmap Tuple.second pCode_ + + bracketed : Parser String + bracketed = + lazy (\() -> pLinkLabel) + |> fmap inBrackets + + inBrackets : String -> String + inBrackets t = + "[" ++ t ++ "]" + in + char '[' + |> bind + (\_ -> + fmap String.concat + (manyTill (oneOf regChunk (oneOf pEscaped (oneOf bracketed codeChunk))) (char ']')) + ) + + +{-| A URL in a link or reference. This may optionally be contained +in `<..>`; otherwise whitespace and unbalanced right parentheses +aren't allowed. Newlines aren't allowed in any case. +-} +pLinkUrl : Parser String +pLinkUrl = + oneOf (char '<' |> bind (\_ -> return True)) (return False) + |> bind + (\inPointy -> + if inPointy then + manyTill (pSatisfy (\c -> c /= '\u{000D}' && c /= '\n')) (char '>') + |> fmap String.fromList + + else + let + regChunk : Parser String + regChunk = + oneOf (takeWhile1 (notInClass " \n()\\")) pEscaped + + parenChunk : () -> Parser String + parenChunk () = + char '(' + |> bind (\_ -> manyTill (oneOf regChunk (lazy parenChunk)) (char ')')) + |> fmap (parenthesize << String.concat) + + parenthesize : String -> String + parenthesize x = + "(" ++ x ++ ")" + in + fmap String.concat (many (oneOf regChunk (parenChunk ()))) + ) + + +{-| A link title, single or double quoted or in parentheses. +Note that Markdown.pl doesn't allow the parenthesized form in +inline links -- only in references -- but this restriction seems +arbitrary, so we remove it here. +-} +pLinkTitle : Parser String +pLinkTitle = + satisfy (\c -> c == '"' || c == '\'' || c == '(') + |> bind + (\c -> + peekChar + |> bind + (\next -> + case next of + Nothing -> + mzero + + Just x -> + if isWhitespace x then + mzero + + else if x == ')' then + mzero + + else + return () + ) + |> bind + (\_ -> + let + ender : Char + ender = + if c == '(' then + ')' + + else + c + + pEnder : Parser Char + pEnder = + bind (\_ -> char ender) (nfb (skip Char.isAlphaNum)) + + regChunk : Parser String + regChunk = + oneOf (takeWhile1 (\x -> x /= ender && x /= '\\')) pEscaped + + nestedChunk : Parser String + nestedChunk = + lazy (\() -> pLinkTitle) + |> fmap (\x -> String.fromChar c ++ x ++ String.fromChar ender) + in + fmap String.concat (manyTill (oneOf regChunk nestedChunk) pEnder) + ) + ) + + +{-| A link reference is a square-bracketed link label, a colon, +optional space or newline, a URL, optional space or newline, +and an optional link title. (Note: we assume the input is +pre-stripped, with no leading/trailing spaces.) +-} +pReference : Parser ( String, String, String ) +pReference = + pLinkLabel + |> bind + (\lab -> + char ':' + |> bind (\_ -> scanSpnl) + |> bind (\_ -> pLinkUrl) + |> bind + (\url -> + option "" (scanSpnl |> bind (\_ -> pLinkTitle)) + |> bind + (\tit -> + endOfInput + |> fmap (\_ -> ( lab, url, tit )) + ) + ) + ) + + +{-| Parses an escaped character and returns a Text. +-} +pEscaped : Parser String +pEscaped = + fmap String.fromChar (skip ((==) '\\') |> bind (\_ -> satisfy isEscapable)) + + +{-| Parses a (possibly escaped) character satisfying the predicate. +-} +pSatisfy : (Char -> Bool) -> Parser Char +pSatisfy p = + oneOf (satisfy (\c -> c /= '\\' && p c)) + (char '\\' |> bind (\_ -> satisfy (\c -> isEscapable c && p c))) + + +{-| Parse a text into inlines, resolving reference links +using the reference map. +-} +parseInlines : ReferenceMap -> String -> Inlines +parseInlines refmap t = + case parse (fmap List.concat (leftSequence (many (pInline refmap)) endOfInput)) t of + Err e -> + -- should not happen + crash ("parseInlines: " ++ showParseError e) + + Ok r -> + r + + +pInline : ReferenceMap -> Parser Inlines +pInline refmap = + oneOf pAsciiStr + (oneOf pSpace + -- strong/emph + (oneOf (pEnclosure '*' refmap) + (oneOf (notAfter Char.isAlphaNum |> bind (\_ -> pEnclosure '_' refmap)) + (oneOf pCode + (oneOf (pLink refmap) + (oneOf (pImage refmap) + (oneOf pRawHtml + (oneOf pAutolink + (oneOf pEntity pSym) + ) + ) + ) + ) + ) + ) + ) + ) + + +{-| Parse spaces or newlines, and determine whether +we have a regular space, a line break (two spaces before +a newline), or a soft break (newline without two spaces +before). +-} +pSpace : Parser Inlines +pSpace = + takeWhile1 isWhitespace + |> bind + (\ss -> + return + (List.singleton + (if String.any ((==) '\n') ss then + if String.startsWith " " ss then + LineBreak + + else + SoftBreak + + else + Space + ) + ) + ) + + +isAsciiAlphaNum : Char -> Bool +isAsciiAlphaNum c = + (c >= 'a' && c <= 'z') + || (c >= 'A' && c <= 'Z') + || (c >= '0' && c <= '9') + + +pAsciiStr : Parser Inlines +pAsciiStr = + takeWhile1 isAsciiAlphaNum + |> bind + (\t -> + peekChar + |> bind + (\mbc -> + case mbc of + Just ':' -> + if Set.member t schemeSet then + pUri t + + else + return (List.singleton (Str t)) + + _ -> + return (List.singleton (Str t)) + ) + ) + + +{-| Catch all -- parse an escaped character, an escaped +newline, or any remaining symbol character. +-} +pSym : Parser Inlines +pSym = + anyChar + |> bind + (\c -> + let + ch : Char -> List Inline + ch = + List.singleton << Str << String.fromChar + in + if c == '\\' then + oneOf (fmap ch (satisfy isEscapable)) + (oneOf (fmap (\_ -> List.singleton LineBreak) (satisfy ((==) '\n'))) + (return (ch '\\')) + ) + + else + return (ch c) + ) + + +{-| plus +the unofficial schemes coap, doi, javascript. +-} +schemes : List String +schemes = + [ -- unofficial + "coap" + , "doi" + , "javascript" + + -- official + , "aaa" + , "aaas" + , "about" + , "acap" + , "cap" + , "cid" + , "crid" + , "data" + , "dav" + , "dict" + , "dns" + , "file" + , "ftp" + , "geo" + , "go" + , "gopher" + , "h323" + , "http" + , "https" + , "iax" + , "icap" + , "im" + , "imap" + , "info" + , "ipp" + , "iris" + , "iris.beep" + , "iris.xpc" + , "iris.xpcs" + , "iris.lwz" + , "ldap" + , "mailto" + , "mid" + , "msrp" + , "msrps" + , "mtqp" + , "mupdate" + , "news" + , "nfs" + , "ni" + , "nih" + , "nntp" + , "opaquelocktoken" + , "pop" + , "pres" + , "rtsp" + , "service" + , "session" + , "shttp" + , "sieve" + , "sip" + , "sips" + , "sms" + , "snmp" + , "soap.beep" + , "soap.beeps" + , "tag" + , "tel" + , "telnet" + , "tftp" + , "thismessage" + , "tn3270" + , "tip" + , "tv" + , "urn" + , "vemmi" + , "ws" + , "wss" + , "xcon" + , "xcon-userid" + , "xmlrpc.beep" + , "xmlrpc.beeps" + , "xmpp" + , "z39.50r" + , "z39.50s" + + -- provisional + , "adiumxtra" + , "afp" + , "afs" + , "aim" + , "apt" + , "attachment" + , "aw" + , "beshare" + , "bitcoin" + , "bolo" + , "callto" + , "chrome" + , "chrome-extension" + , "com-eventbrite-attendee" + , "content" + , "cvs" + , "dlna-playsingle" + , "dlna-playcontainer" + , "dtn" + , "dvb" + , "ed2k" + , "facetime" + , "feed" + , "finger" + , "fish" + , "gg" + , "git" + , "gizmoproject" + , "gtalk" + , "hcp" + , "icon" + , "ipn" + , "irc" + , "irc6" + , "ircs" + , "itms" + , "jar" + , "jms" + , "keyparc" + , "lastfm" + , "ldaps" + , "magnet" + , "maps" + , "market" + , "message" + , "mms" + , "ms-help" + , "msnim" + , "mumble" + , "mvn" + , "notes" + , "oid" + , "palm" + , "paparazzi" + , "platform" + , "proxy" + , "psyc" + , "query" + , "res" + , "resource" + , "rmi" + , "rsync" + , "rtmp" + , "secondlife" + , "sftp" + , "sgn" + , "skype" + , "smb" + , "soldat" + , "spotify" + , "ssh" + , "steam" + , "svn" + , "teamspeak" + , "things" + , "udp" + , "unreal" + , "ut2004" + , "ventrilo" + , "view-source" + , "webcal" + , "wtai" + , "wyciwyg" + , "xfire" + , "xri" + , "ymsgr" + ] + + +{-| Make them a set for more efficient lookup. +-} +schemeSet : Set String +schemeSet = + Set.fromList (schemes ++ List.map String.toUpper schemes) + + +{-| Parse a URI, using heuristics to avoid capturing final punctuation. +-} +pUri : String -> Parser Inlines +pUri scheme = + char ':' + |> bind (\_ -> scan (OpenParens 0) uriScanner) + |> bind + (\x -> + guard (not (String.isEmpty x)) + |> bind + (\_ -> + let + ( rawuri, endingpunct ) = + case String.uncons (String.reverse x) of + Just ( c, _ ) -> + if String.contains (String.fromChar c) ".;?!:," then + ( scheme ++ ":" ++ x, [ Str (String.fromChar c) ] ) + + else + ( scheme ++ ":" ++ x, [] ) + + _ -> + ( scheme ++ ":" ++ x, [] ) + in + return (autoLink rawuri ++ endingpunct) + ) + ) + + +{-| Scan non-ascii characters and ascii characters allowed in a URI. +We allow punctuation except when followed by a space, since +we don't want the trailing '.' in ' +We want to allow + +as a URL, while NOT picking up the closing paren in +() +So we include balanced parens in the URL. +-} +type OpenParens + = OpenParens Int + + +uriScanner : OpenParens -> Char -> Maybe OpenParens +uriScanner st c = + case ( st, c ) of + ( _, ' ' ) -> + Nothing + + ( _, '\n' ) -> + Nothing + + ( OpenParens n, '(' ) -> + Just (OpenParens (n + 1)) + + ( OpenParens n, ')' ) -> + if n > 0 then + Just (OpenParens (n - 1)) + + else + Nothing + + ( _, '+' ) -> + Just st + + ( _, '/' ) -> + Just st + + _ -> + if isSpace c then + Nothing + + else + Just st + + +{-| Parses material enclosed in \*s, \*\*s, \_s, or \_\_s. +Designed to avoid backtracking. +-} +pEnclosure : Char -> ReferenceMap -> Parser Inlines +pEnclosure c refmap = + takeWhile1 ((==) c) + |> bind + (\cs -> + oneOf + (pSpace |> fmap ((::) (Str cs))) + (case String.length cs of + 3 -> + pThree c refmap + + 2 -> + pTwo c refmap [] + + 1 -> + pOne c refmap [] + + _ -> + return (List.singleton (Str cs)) + ) + ) + + +{-| singleton sequence or empty if contents are empty +-} +single : (Inlines -> Inline) -> Inlines -> Inlines +single constructor ils = + if List.isEmpty ils then + [] + + else + List.singleton (constructor ils) + + +{-| parse inlines til you hit a c, and emit Emph. +if you never hit a c, emit '\*' + inlines parsed. +-} +pOne : Char -> ReferenceMap -> Inlines -> Parser Inlines +pOne c refmap prefix = + fmap List.concat + (many + (oneOf (nfbChar c |> bind (\_ -> pInline refmap)) + (string (String.fromList [ c, c ]) + |> bind (\_ -> nfbChar c) + |> bind (\_ -> pTwo c refmap []) + ) + ) + ) + |> bind + (\contents -> + oneOf (char c |> bind (\_ -> return (single Emph (prefix ++ contents)))) + (return (Str (String.fromChar c) :: (prefix ++ contents))) + ) + + +{-| parse inlines til you hit two c's, and emit Strong. +if you never do hit two c's, emit '\*\*' plus + inlines parsed. +-} +pTwo : Char -> ReferenceMap -> Inlines -> Parser Inlines +pTwo c refmap prefix = + let + ender : Parser String + ender = + string (String.fromList [ c, c ]) + in + fmap List.concat (many (nfb ender |> bind (\_ -> pInline refmap))) + |> bind + (\contents -> + oneOf (ender |> fmap (\_ -> single Strong (prefix ++ contents))) + (return (Str (String.fromList [ c, c ]) :: (prefix ++ contents))) + ) + + +{-| parse inlines til you hit one c or a sequence of two c's. +If one c, emit Emph and then parse pTwo. +if two c's, emit Strong and then parse pOne. +-} +pThree : Char -> ReferenceMap -> Parser Inlines +pThree c refmap = + fmap List.concat (many (nfbChar c |> bind (\_ -> pInline refmap))) + |> bind + (\contents -> + oneOf (string (String.fromList [ c, c ]) |> bind (\_ -> pOne c refmap (single Strong contents))) + (oneOf (char c |> bind (\_ -> pTwo c refmap (single Emph contents))) + (return (Str (String.fromList [ c, c, c ]) :: contents)) + ) + ) + + +{-| Inline code span. +-} +pCode : Parser Inlines +pCode = + fmap Tuple.first pCode_ + + +{-| this is factored out because it needed in pLinkLabel. +-} +pCode_ : Parser ( Inlines, String ) +pCode_ = + takeWhile1 ((==) '`') + |> bind + (\ticks -> + let + end : Parser () + end = + string ticks |> bind (\_ -> nfb (char '`')) + + nonBacktickSpan : Parser String + nonBacktickSpan = + takeWhile1 ((/=) '`') + + backtickSpan : Parser String + backtickSpan = + takeWhile1 ((==) '`') + in + manyTill (oneOf nonBacktickSpan backtickSpan) end + |> fmap String.concat + |> fmap + (\contents -> + ( List.singleton (Code (String.trim contents)), ticks ++ contents ++ ticks ) + ) + ) + + +pLink : ReferenceMap -> Parser Inlines +pLink refmap = + pLinkLabel + |> bind + (\lab -> + let + lab_ : Inlines + lab_ = + parseInlines refmap lab + in + oneOf (oneOf (pInlineLink lab_) (pReferenceLink refmap lab lab_)) + -- fallback without backtracking if it's not a link: + (return (Str "[" :: lab_ ++ [ Str "]" ])) + ) + + +{-| An inline link: [label](/url "optional title") +-} +pInlineLink : Inlines -> Parser Inlines +pInlineLink lab = + char '(' + |> bind + (\_ -> + scanSpaces + |> bind (\_ -> pLinkUrl) + |> bind + (\url -> + -- tit <- option "" $ scanSpnl *> pLinkTitle <* scanSpaces + option "" (scanSpnl |> bind (\_ -> bind (\_ -> pLinkTitle) scanSpaces)) + |> bind + (\tit -> + char ')' + |> fmap (\_ -> [ Link lab (Url url) tit ]) + ) + ) + ) + + +{-| A reference link: [label], [foo][label], or [label]. +-} +pReferenceLink : ReferenceMap -> String -> Inlines -> Parser Inlines +pReferenceLink _ rawlab lab = + option rawlab (scanSpnl |> bind (\_ -> pLinkLabel)) + |> fmap (\ref -> [ Link lab (Ref ref) "" ]) + + +{-| An image: ! followed by a link. +-} +pImage : ReferenceMap -> Parser Inlines +pImage refmap = + char '!' + |> bind + (\_ -> + oneOf (fmap linkToImage (pLink refmap)) (return [ Str "!" ]) + ) + + +linkToImage : Inlines -> Inlines +linkToImage ils = + case ils of + (Link lab (Url url) tit) :: [] -> + [ Image lab url tit ] + + _ -> + Str "!" :: ils + + +{-| An entity. We store these in a special inline element. +This ensures that entities in the input come out as +entities in the output. Alternatively we could simply +convert them to characters and store them as Str inlines. +-} +pEntity : Parser Inlines +pEntity = + char '&' + |> bind (\_ -> oneOf pCharEntity (oneOf pDecEntity pHexEntity)) + |> bind + (\res -> + char ';' + |> bind (\_ -> return (List.singleton (Entity ("&" ++ res ++ ";")))) + ) + + +pCharEntity : Parser String +pCharEntity = + takeWhile1 (\c -> Char.isAlpha c) + + +pDecEntity : Parser String +pDecEntity = + char '#' + |> bind (\_ -> takeWhile1 Char.isDigit) + |> bind (\res -> return ("#" ++ res)) + + +pHexEntity : Parser String +pHexEntity = + char '#' + |> bind (\_ -> oneOf (char 'X') (char 'x')) + |> bind + (\x -> + takeWhile1 Char.isHexDigit + |> bind + (\res -> + return ("#" ++ String.fromChar x ++ res) + ) + ) + + + +-- Raw HTML tag or comment. + + +pRawHtml : Parser Inlines +pRawHtml = + fmap (List.singleton << RawHtml) (oneOf (fmap Tuple.second pHtmlTag) pHtmlComment) + + +{-| A link like this: or [me@mydomain.edu](mailto:me@mydomain.edu). +Markdown.pl does email obfuscation; we don't bother with that here. +-} +pAutolink : Parser Inlines +pAutolink = + skip ((==) '<') + |> bind (\_ -> takeWhile1 (\c -> c /= ':' && c /= '@')) + |> bind + (\s -> + takeWhile1 (\c -> c /= '>' && c /= ' ') + |> bind + (\rest -> + skip ((==) '>') + |> bind + (\_ -> + if String.startsWith "@" rest then + return (emailLink (s ++ rest)) + + else if Set.member s schemeSet then + return (autoLink (s ++ rest)) + + else + fail "Unknown contents of <>" + ) + ) + ) + + +autoLink : String -> Inlines +autoLink t = + let + toInlines : String -> Inlines + toInlines t_ = + case parse pToInlines t_ of + Ok r -> + r + + Err e -> + crash <| "autolink: " ++ showParseError e + + pToInlines : Parser Inlines + pToInlines = + fmap List.concat (many strOrEntity) + + strOrEntity : Parser Inlines + strOrEntity = + oneOf (fmap (List.singleton << Str) (takeWhile1 ((/=) '&'))) + (oneOf pEntity (fmap (List.singleton << Str) (string "&"))) + in + List.singleton <| Link (toInlines t) (Url t) "" + + +emailLink : String -> Inlines +emailLink t = + [ Link [ Str t ] (Url ("mailto:" ++ t)) "" ] diff --git a/src/Common/Format/Cheapskate/Parse.elm b/src/Common/Format/Cheapskate/Parse.elm new file mode 100644 index 0000000000..6f57f1c2c2 --- /dev/null +++ b/src/Common/Format/Cheapskate/Parse.elm @@ -0,0 +1,1249 @@ +module Common.Format.Cheapskate.Parse exposing (markdown) + +import Common.Format.Cheapskate.Inlines exposing (pHtmlTag, pLinkLabel, pReference, parseInlines) +import Common.Format.Cheapskate.ParserCombinators exposing (Parser, Position(..), apply, bind, char, count, endOfInput, fmap, getPosition, guard, lookAhead, many, notFollowedBy, oneOf, option, parse, pure, return, satisfy, setPosition, showParseError, skip, skipWhile, string, takeText, takeWhile, takeWhile1, unless) +import Common.Format.Cheapskate.Types exposing (Block(..), Blocks, CodeAttr(..), Doc(..), HtmlTagType(..), ListType(..), NumWrapper(..), Options, ReferenceMap) +import Common.Format.Cheapskate.Util exposing (Scanner, isWhitespace, joinLines, nfb, normalizeReference, scanBlankline, scanChar, scanIndentSpace, scanNonindentSpace, scanSpaces, scanSpacesToColumn, tabFilter, upToCountChars) +import Common.Format.RWS as RWS exposing (RWS) +import Data.Map as Dict +import List.Extra as List +import Set exposing (Set) +import Utils.Crash exposing (crash) + + + +-- PARSE + + +markdown : Options -> String -> Doc +markdown opts = + Doc opts << processDocument << processLines + + + +{- General parsing strategy: + + Step 1: processLines + + We process the input line by line. Each line modifies the + container stack, by adding a leaf to the current open container, + sometimes after closing old containers and/or opening new ones. + + To open a container is to add it to the top of the container stack, + so that new content will be added under this container. + To close a container is to remove it from the container stack and + make it a child of the container above it on the container stack. + + When all the input has been processed, we close all open containers + except the root (Document) container. At this point we should also + have a ReferenceMap containing any defined link references. + + Step 2: processDocument + + We then convert this container structure into an AST. This principally + involves (a) gathering consecutive ListItem containers into lists, (b) + gathering TextLine nodes that don't belong to verbatim containers into + paragraphs, and (c) parsing the inline contents of non-verbatim TextLines. + +-} + + +{-| Container stack definitions: +-} +type ContainerStack + = ContainerStack {- top -} Container {- rest -} (List Container) + + +type alias LineNumber = + Int + + +{-| Generic type for a container or a leaf. +-} +type Elt + = C Container + | L LineNumber Leaf + + +type Container + = Container ContainerType (List Elt) + + +type ContainerType + = Document + | BlockQuote + | ListItem + { markerColumn : Int + , padding : Int + , listType : ListType + } + | FencedCode + { startColumn : Int + , fence : String + , info : String + } + | IndentedCode + | RawHtmlBlock + | Reference + + +{-| Scanners that must be satisfied if the current open container +is to be continued on a new line (ignoring lazy continuations). +-} +containerContinue : Container -> Scanner +containerContinue (Container containerType _) = + case containerType of + BlockQuote -> + scanNonindentSpace |> bind (\_ -> scanBlockquoteStart) + + IndentedCode -> + scanIndentSpace + + FencedCode { startColumn } -> + scanSpacesToColumn startColumn + + RawHtmlBlock -> + nfb scanBlankline + + ListItem { markerColumn, padding } -> + oneOf scanBlankline + (scanSpacesToColumn (markerColumn + 1) + |> bind (\_ -> upToCountChars (padding - 1) ((==) ' ')) + |> bind (\_ -> return ()) + ) + + Reference -> + nfb scanBlankline + |> bind (\_ -> nfb (scanNonindentSpace |> bind (\_ -> scanReference))) + + _ -> + return () + + + +-- Defines parsers that open new containers. + + +containerStart : Bool -> Parser ContainerType +containerStart _ = + scanNonindentSpace + |> bind + (\_ -> + oneOf (fmap (\_ -> BlockQuote) scanBlockquoteStart) + parseListMarker + ) + + + +-- Defines parsers that open new verbatim containers (containers +-- that take only TextLine and BlankLine as children). + + +verbatimContainerStart : Bool -> Parser ContainerType +verbatimContainerStart lastLineIsText = + scanNonindentSpace + |> bind + (\_ -> + oneOf parseCodeFence + (oneOf + (guard (not lastLineIsText) + |> bind + (\_ -> + nfb scanBlankline + |> bind (\_ -> char ' ') + |> fmap (\_ -> IndentedCode) + ) + ) + (oneOf (guard (not lastLineIsText) |> bind (\_ -> fmap (\_ -> RawHtmlBlock) parseHtmlBlockStart)) + (guard (not lastLineIsText) |> bind (\_ -> fmap (\_ -> Reference) scanReference)) + ) + ) + ) + + + +-- Leaves of the container structure (they don't take children). + + +type Leaf + = TextLine String + | BlankLine String + | ATXHeader Int String + | SetextHeader Int String + | Rule + + +type alias ContainerM a = + RWS () ContainerStack a + + + +-- Close the whole container stack, leaving only the root Document container. + + +closeStack : ContainerM Container +closeStack = + RWS.get + |> RWS.bind + (\(ContainerStack top rest) -> + if List.isEmpty rest then + RWS.return top + + else + closeContainer |> RWS.bind (\_ -> closeStack) + ) + + + +-- Close the top container on the stack. If the container is a Reference +-- container, attempt to parse the reference and update the reference map. +-- If it is a list item container, move a final BlankLine outside the list +-- item. + + +closeContainer : ContainerM () +closeContainer = + RWS.get + |> RWS.bind + (\(ContainerStack top rest) -> + case top of + Container Reference cs__ -> + case parse pReference (String.trim <| joinLines <| List.map extractText cs__) of + Ok ( lab, lnk, tit ) -> + RWS.tell (Dict.singleton identity (normalizeReference lab) ( lnk, tit )) + |> RWS.bind + (\_ -> + case rest of + (Container ct_ cs_) :: rs -> + RWS.put (ContainerStack (Container ct_ (cs_ ++ [ C top ])) rs) + + [] -> + RWS.return () + ) + + Err _ -> + -- pass over in silence if ref doesn't parse? + case rest of + c :: cs -> + RWS.put (ContainerStack c cs) + + [] -> + RWS.return () + + Container ((ListItem _) as li) cs__ -> + case rest of + -- move final BlankLine outside of list item + (Container ct_ cs_) :: rs -> + case List.reverse cs__ of + ((L _ (BlankLine _)) as b) :: zs -> + RWS.put + (ContainerStack + (if List.isEmpty zs then + Container ct_ (cs_ ++ [ C (Container li zs) ]) + + else + Container ct_ (cs_ ++ [ C (Container li zs), b ]) + ) + rs + ) + + _ -> + RWS.put (ContainerStack (Container ct_ (cs_ ++ [ C top ])) rs) + + [] -> + RWS.return () + + _ -> + case rest of + (Container ct_ cs_) :: rs -> + RWS.put (ContainerStack (Container ct_ (cs_ ++ [ C top ])) rs) + + [] -> + RWS.return () + ) + + + +-- Add a leaf to the top container. + + +addLeaf : LineNumber -> Leaf -> ContainerM () +addLeaf lineNum lf = + RWS.get + |> RWS.bind + (\(ContainerStack top rest) -> + case ( top, lf ) of + ( Container ((ListItem _) as ct) cs, BlankLine _ ) -> + case List.reverse cs of + (L _ (BlankLine _)) :: _ -> + -- two blanks break out of list item: + closeContainer + |> RWS.bind (\_ -> addLeaf lineNum lf) + + _ -> + RWS.put (ContainerStack (Container ct (L lineNum lf :: cs)) rest) + + ( Container ct cs, _ ) -> + RWS.put (ContainerStack (Container ct (L lineNum lf :: cs)) rest) + ) + + + +-- Add a container to the container stack. + + +addContainer : ContainerType -> ContainerM () +addContainer ct = + RWS.modify + (\(ContainerStack top rest) -> + ContainerStack (Container ct []) (top :: rest) + ) + + + +-- Step 2 + + +{-| Convert Document container and reference map into an AST. +-} +processDocument : ( Container, ReferenceMap ) -> Blocks +processDocument ( Container ct cs, refmap ) = + case ct of + Document -> + processElts refmap cs + + _ -> + crash "top level container is not Document" + + +{-| Turn the result of `processLines` into a proper AST. +This requires grouping text lines into paragraphs +and list items into lists, handling blank lines, +parsing inline contents of texts and resolving referencess. +-} +processElts : ReferenceMap -> List Elt -> Blocks +processElts refmap elts = + case elts of + [] -> + [] + + (L _ lf) :: rest -> + case lf of + -- Special handling of @docs lines in Elm: + TextLine t -> + case stripPrefix "@docs" t of + Just terms1 -> + let + docs : List String + docs = + terms1 :: List.map (cleanDoc << extractText) docLines + + ( docLines, rest_ ) = + List.span isDocLine rest + + isDocLine : Elt -> Bool + isDocLine elt = + case elt of + L _ (TextLine _) -> + True + + _ -> + False + + cleanDoc : String -> String + cleanDoc lin = + case stripPrefix "@docs" lin of + Nothing -> + lin + + Just stripped -> + stripped + in + (ElmDocs <| List.filter ((/=) []) <| List.map (List.filter ((/=) "") << List.map String.trim << String.split ",") docs) + :: processElts refmap rest_ + + Nothing -> + -- Gobble text lines and make them into a Para: + let + txt : String + txt = + String.trimRight <| + joinLines <| + List.map String.trimLeft + (t :: List.map extractText textlines) + + ( textlines, rest_ ) = + List.span isTextLine rest + + isTextLine : Elt -> Bool + isTextLine elt = + case elt of + L _ (TextLine s) -> + not (String.startsWith "@docs" s) + + _ -> + False + in + Para (parseInlines refmap txt) + :: processElts refmap rest_ + + -- Blanks at outer level are ignored: + BlankLine _ -> + processElts refmap rest + + -- Headers: + ATXHeader lvl t -> + (Header lvl <| parseInlines refmap t) + :: processElts refmap rest + + SetextHeader lvl t -> + (Header lvl <| parseInlines refmap t) + :: processElts refmap rest + + -- Horizontal rule: + Rule -> + HRule :: processElts refmap rest + + (C (Container ct cs)) :: rest -> + let + isBlankLine : Elt -> Bool + isBlankLine x = + case x of + L _ (BlankLine _) -> + True + + _ -> + False + + tightListItem : List Elt -> Bool + tightListItem xs = + case xs of + [] -> + True + + _ -> + not <| List.any isBlankLine xs + in + case ct of + Document -> + crash "Document container found inside Document" + + BlockQuote -> + (Blockquote <| processElts refmap cs) + :: processElts refmap rest + + -- List item? Gobble up following list items of the same type + -- (skipping blank lines), determine whether the list is tight or + -- loose, and generate a List. + ListItem { listType } -> + let + xs : List Elt + xs = + takeListItems rest + + rest_ : List Elt + rest_ = + List.drop (List.length xs) rest + + -- take list items as long as list type matches and we + -- don't hit two blank lines: + takeListItems : List Elt -> List Elt + takeListItems ys = + case ys of + (C ((Container (ListItem li_) _) as c)) :: zs -> + if listTypesMatch li_.listType listType then + C c :: takeListItems zs + + else + [] + + ((L _ (BlankLine _)) as lf) :: ((C (Container (ListItem li_) _)) as c) :: zs -> + if listTypesMatch li_.listType listType then + lf :: c :: takeListItems zs + + else + [] + + _ -> + [] + + listTypesMatch : ListType -> ListType -> Bool + listTypesMatch listType_ listType__ = + case ( listType_, listType__ ) of + ( Bullet c1, Bullet c2 ) -> + c1 == c2 + + ( Numbered w1 _, Numbered w2 _ ) -> + w1 == w2 + + _ -> + False + + items : List (List Elt) + items = + List.filterMap getItem + (Container ct cs + :: List.filterMap + (\x -> + case x of + C c -> + Just c + + _ -> + Nothing + ) + xs + ) + + getItem : Container -> Maybe (List Elt) + getItem container = + case container of + Container (ListItem _) cs_ -> + Just cs_ + + _ -> + Nothing + + items_ : List Blocks + items_ = + List.map (processElts refmap) items + + isTight : Bool + isTight = + tightListItem xs && List.all tightListItem items + in + List isTight listType items_ :: processElts refmap rest_ + + FencedCode { info } -> + let + txt : String + txt = + joinLines <| List.map extractText cs + + attr : CodeAttr + attr = + CodeAttr { codeLang = x, codeInfo = String.trim y } + + ( x, y ) = + stringBreak ((==) ' ') info + in + CodeBlock attr txt + :: processElts refmap rest + + IndentedCode -> + let + txt : String + txt = + joinLines <| + stripTrailingEmpties <| + List.concatMap extractCode cbs + + stripTrailingEmpties : List String -> List String + stripTrailingEmpties = + List.reverse + << List.dropWhile (String.all ((==) ' ')) + << List.reverse + + -- explanation for next line: when we parsed + -- the blank line, we dropped 0-3 spaces. + -- but for this, code block context, we want + -- to have dropped 4 spaces. we simply drop + -- one more: + extractCode : Elt -> List String + extractCode elt = + case elt of + L _ (BlankLine t) -> + [ String.dropLeft 1 t ] + + C (Container IndentedCode cs_) -> + List.map extractText cs_ + + _ -> + [] + + ( cbs, rest_ ) = + List.span isIndentedCodeOrBlank + (C (Container ct cs) :: rest) + + isIndentedCodeOrBlank : Elt -> Bool + isIndentedCodeOrBlank elt = + case elt of + L _ (BlankLine _) -> + True + + C (Container IndentedCode _) -> + True + + _ -> + False + in + CodeBlock (CodeAttr { codeLang = "", codeInfo = "" }) txt + :: processElts refmap rest_ + + RawHtmlBlock -> + let + txt : String + txt = + joinLines (List.map extractText cs) + in + HtmlBlock txt :: processElts refmap rest + + -- References have already been taken into account in the reference map, + -- so we just skip. + Reference -> + let + refs : List Elt -> List ( String, String, String ) + refs cs_ = + List.map (extractRef << extractText) cs_ + + extractRef : String -> ( String, String, String ) + extractRef t = + case parse pReference (String.trim t) of + Ok ( lab, lnk, tit ) -> + ( lab, lnk, tit ) + + Err _ -> + ( "??", "??", "??" ) + + processElts_ : List (List ( String, String, String )) -> List Elt -> Blocks + processElts_ acc pass = + case pass of + (C (Container Reference cs_)) :: rest_ -> + processElts_ (refs cs_ :: acc) rest_ + + _ -> + (ReferencesBlock <| List.concat <| List.reverse acc) + :: processElts refmap pass + in + processElts_ [] (C (Container ct cs) :: rest) + + +extractText : Elt -> String +extractText elt = + case elt of + L _ (TextLine t) -> + t + + _ -> + "" + + + +-- Step 1 + + +processLines : String -> ( Container, ReferenceMap ) +processLines t = + let + lns : List ( LineNumber, String ) + lns = + List.indexedMap (\i ln -> ( i + 1, ln )) (List.map tabFilter (String.lines t)) + + startState : ContainerStack + startState = + ContainerStack (Container Document []) [] + in + RWS.evalRWS (RWS.mapM_ processLine lns |> RWS.bind (\_ -> closeStack)) () startState + + + +-- The main block-parsing function. +-- We analyze a line of text and modify the container stack accordingly, +-- adding a new leaf, or closing or opening containers. + + +processLine : ( LineNumber, String ) -> ContainerM () +processLine ( lineNumber, txt ) = + RWS.get + |> RWS.bind + (\(ContainerStack ((Container ct cs) as top) rest) -> + -- Apply the line-start scanners appropriate for each nested container. + -- Return the remainder of the string, and the number of unmatched + -- containers. + let + ( t_, numUnmatched ) = + tryOpenContainers (List.reverse (top :: rest)) txt + + -- Some new containers can be started only after a blank. + lastLineIsText : Bool + lastLineIsText = + (numUnmatched == 0) + && (case List.reverse cs of + (L _ (TextLine _)) :: _ -> + True + + _ -> + False + ) + + addNew : ( List ContainerType, Leaf ) -> () -> ContainerStack -> ( (), ContainerStack, Dict.Dict String String ( String, String ) ) + addNew ( ns, lf ) = + RWS.mapM_ addContainer ns + |> RWS.bind + (\_ -> + case ( List.reverse ns, lf ) of + -- don't add extra blank at beginning of fenced code block + ( (FencedCode _) :: _, BlankLine _ ) -> + RWS.return () + + _ -> + addLeaf lineNumber lf + ) + in + -- Process the rest of the line in a way that makes sense given + -- the container type at the top of the stack (ct): + case ( ct, numUnmatched == 0 ) of + -- If it's a verbatim line container, add the line. + ( RawHtmlBlock, True ) -> + addLeaf lineNumber (TextLine t_) + + ( IndentedCode, True ) -> + addLeaf lineNumber (TextLine t_) + + ( FencedCode { fence }, _ ) -> + -- here we don't check numUnmatched because we allow laziness + if + String.startsWith fence t_ + -- closing code fence + then + closeContainer + + else + addLeaf lineNumber (TextLine t_) + + ( Reference, _ ) -> + let + ( ns, lf ) = + tryNewContainers lastLineIsText (String.length txt - String.length t_) t_ + in + closeContainer + |> RWS.bind (\_ -> addNew ( ns, lf )) + + -- otherwise, parse the remainder to see if we have new container starts: + _ -> + case tryNewContainers lastLineIsText (String.length txt - String.length t_) t_ of + -- lazy continuation: text line, last line was text, no new containers, + -- some unmatched containers: + ( [] as ns, (TextLine t) as lf ) -> + if + numUnmatched + > 0 + && (case List.reverse cs of + (L _ (TextLine _)) :: _ -> + True + + _ -> + False + ) + && ct + /= IndentedCode + then + addLeaf lineNumber (TextLine t) + + else + -- close unmatched containers, add new ones + RWS.replicateM numUnmatched closeContainer + |> RWS.bind (\_ -> addNew ( ns, lf )) + + -- if it's a setext header line and the top container has a textline + -- as last child, add a setext header: + ( [] as ns, (SetextHeader lev _) as lf ) -> + if numUnmatched == 0 then + case List.reverse cs of + (L _ (TextLine t)) :: cs_ -> + -- replace last text line with setext header + RWS.put + (ContainerStack + (Container ct + (List.reverse (L lineNumber (SetextHeader lev t) :: cs_)) + ) + rest + ) + + -- Note: the following case should not occur, since + -- we don't add a SetextHeader leaf unless lastLineIsText. + _ -> + RWS.error "setext header line without preceding text line" + + else + -- close unmatched containers, add new ones + RWS.replicateM numUnmatched closeContainer + |> RWS.bind (\_ -> addNew ( ns, lf )) + + -- otherwise, close all the unmatched containers, add the new + -- containers, and finally add the new leaf: + ( ns, lf ) -> + -- close unmatched containers, add new ones + RWS.replicateM numUnmatched closeContainer + |> RWS.bind (\_ -> addNew ( ns, lf )) + ) + + + +-- Try to match the scanners corresponding to any currently open containers. +-- Return remaining text after matching scanners, plus the number of open +-- containers whose scanners did not match. (These will be closed unless +-- we have a lazy text line.) + + +tryOpenContainers : List Container -> String -> ( String, Int ) +tryOpenContainers cs t = + let + scanners : List (Parser a) -> Parser ( String, Int ) + scanners ss = + case ss of + [] -> + pure Tuple.pair + |> apply takeText + |> apply (pure 0) + + p :: ps -> + oneOf (p |> bind (\_ -> scanners ps)) (fmap Tuple.pair takeText |> apply (pure (List.length (p :: ps)))) + in + case parse (scanners <| List.map containerContinue cs) t of + Ok ( t_, n ) -> + ( t_, n ) + + Err e -> + crash <| + "error parsing scanners: " + ++ showParseError e + + + +-- Try to match parsers for new containers. Return list of new +-- container types, and the leaf to add inside the new containers. + + +tryNewContainers : Bool -> Int -> String -> ( List ContainerType, Leaf ) +tryNewContainers lastLineIsText offset t = + let + newContainers : Parser ( List ContainerType, Leaf ) + newContainers = + getPosition + |> bind + (\(Position ln _) -> + setPosition (Position ln (offset + 1)) + |> bind + (\_ -> + many (containerStart lastLineIsText) + |> bind + (\regContainers -> + option [] (count 1 (verbatimContainerStart lastLineIsText)) + |> bind + (\verbatimContainers -> + if List.isEmpty verbatimContainers then + fmap (Tuple.pair regContainers) (leaf lastLineIsText) + + else + fmap (Tuple.pair (regContainers ++ verbatimContainers)) textLineOrBlank + ) + ) + ) + ) + in + case parse newContainers t of + Ok ( cs, t_ ) -> + ( cs, t_ ) + + Err err -> + crash (showParseError err) + + +textLineOrBlank : Parser Leaf +textLineOrBlank = + let + consolidate : String -> Leaf + consolidate ts = + if String.all isWhitespace ts then + BlankLine ts + + else + TextLine ts + in + fmap consolidate takeText + + + +-- Parse a leaf node. + + +leaf : Bool -> Parser Leaf +leaf lastLineIsText = + scanNonindentSpace + |> bind + (\_ -> + let + removeATXSuffix : String -> String + removeATXSuffix t = + case String.uncons (String.reverse (stringDropWhileEnd (\c -> String.contains (String.fromChar c) " #") t)) of + Nothing -> + "" + + Just ( '\\', t_ ) -> + String.reverse t_ ++ "\\#" + + Just ( c, t_ ) -> + String.reverse (String.cons c t_) + in + oneOf + (pure ATXHeader + |> apply parseAtxHeaderStart + |> apply (fmap (String.trim << removeATXSuffix) takeText) + ) + (oneOf + (guard lastLineIsText + |> bind + (\_ -> + pure SetextHeader + |> apply parseSetextHeaderLine + |> apply (pure "") + ) + ) + (oneOf (fmap (\_ -> Rule) scanHRuleLine) + textLineOrBlank + ) + ) + ) + + + +-- Scanners + + +scanReference : Scanner +scanReference = + fmap (\_ -> ()) (lookAhead (pLinkLabel |> bind (\_ -> scanChar ':'))) + + + +-- Scan the beginning of a blockquote: up to three +-- spaces indent, the `>` character, and an optional space. + + +scanBlockquoteStart : Scanner +scanBlockquoteStart = + scanChar '>' + |> bind (\_ -> option () (scanChar ' ')) + + + +-- Parse the sequence of `#` characters that begins an ATX +-- header, and return the number of characters. We require +-- a space after the initial string of `#`s, as not all markdown +-- implementations do. This is because (a) the ATX reference +-- implementation requires a space, and (b) since we're allowing +-- headers without preceding blank lines, requiring the space +-- avoids accidentally capturing a line like `#8 toggle bolt` as +-- a header. + + +parseAtxHeaderStart : Parser Int +parseAtxHeaderStart = + char '#' + |> bind (\_ -> upToCountChars 5 ((==) '#')) + |> bind + (\hashes -> + -- hashes must be followed by space unless empty header: + notFollowedBy (skip ((/=) ' ')) + |> fmap (\_ -> String.length hashes + 1) + ) + + +parseSetextHeaderLine : Parser Int +parseSetextHeaderLine = + satisfy (\c -> c == '-' || c == '=') + |> bind + (\d -> + let + lev : Int + lev = + if d == '=' then + 1 + + else + 2 + in + skipWhile ((==) d) + |> bind (\_ -> scanBlankline) + |> fmap (\_ -> lev) + ) + + + +-- Scan a horizontal rule line: "...three or more hyphens, asterisks, +-- or underscores on a line by themselves. If you wish, you may use +-- spaces between the hyphens or asterisks." + + +scanHRuleLine : Scanner +scanHRuleLine = + satisfy (\c -> c == '*' || c == '_' || c == '-') + |> bind + (\c -> + count 2 scanSpaces + |> bind (\_ -> skip ((==) c)) + |> bind (\_ -> skipWhile (\x -> x == ' ' || x == c)) + |> bind (\_ -> endOfInput) + ) + + + +-- Parse an initial code fence line, returning +-- the fence part and the rest (after any spaces). + + +parseCodeFence : Parser ContainerType +parseCodeFence = + getPosition + |> bind + (\(Position _ col) -> + oneOf (takeWhile1 ((==) '`')) (takeWhile1 ((==) '~')) + |> bind + (\cs -> + guard (String.length cs >= 3) + |> bind (\_ -> scanSpaces) + |> bind (\_ -> takeWhile (\c -> c /= '`' && c /= '~')) + |> bind + (\rawattr -> + endOfInput + |> fmap + (\_ -> + FencedCode + { startColumn = col + , fence = cs + , info = rawattr + } + ) + ) + ) + ) + + + +-- Parse the start of an HTML block: either an HTML tag or an +-- HTML comment, with no indentation. + + +parseHtmlBlockStart : Parser () +parseHtmlBlockStart = + let + f : HtmlTagType -> Bool + f htmlTagType = + case htmlTagType of + Opening name -> + Set.member name blockHtmlTags + + SelfClosing name -> + Set.member name blockHtmlTags + + Closing name -> + Set.member name blockHtmlTags + in + -- () <$ + lookAhead + (oneOf + (pHtmlTag + |> bind + (\t -> + guard (f (Tuple.first t)) + |> fmap (\_ -> Tuple.second t) + ) + ) + (oneOf (string "")) + ) + |> fmap (\_ -> ()) + + + +-- List of block level tags for HTML 5. + + +blockHtmlTags : Set String +blockHtmlTags = + Set.fromList + [ "article" + , "header" + , "aside" + , "hgroup" + , "blockquote" + , "hr" + , "body" + , "li" + , "br" + , "map" + , "button" + , "object" + , "canvas" + , "ol" + , "caption" + , "output" + , "col" + , "p" + , "colgroup" + , "pre" + , "dd" + , "progress" + , "div" + , "section" + , "dl" + , "table" + , "dt" + , "tbody" + , "embed" + , "textarea" + , "fieldset" + , "tfoot" + , "figcaption" + , "th" + , "figure" + , "thead" + , "footer" + , "tr" + , "form" + , "ul" + , "h1" + , "h2" + , "h3" + , "h4" + , "h5" + , "h6" + , "video" + ] + + + +-- Parse a list marker and return the list type. + + +parseListMarker : Parser ContainerType +parseListMarker = + getPosition + |> bind + (\(Position _ col) -> + oneOf parseBullet parseListNumber + |> bind + (\ty -> + -- padding is 1 if list marker followed by a blank line + -- or indented code. otherwise it's the length of the + -- whitespace between the list marker and the following text: + oneOf (fmap (\_ -> 1) scanBlankline) + (oneOf (fmap (\_ -> 1) (skip ((==) ' ') |> bind (\_ -> lookAhead (count 4 (char ' '))))) + (fmap String.length (takeWhile ((==) ' '))) + ) + |> bind + (\padding_ -> + -- text can't immediately follow the list marker: + guard (padding_ > 0) + |> bind + (\() -> + return + (ListItem + { listType = ty + , markerColumn = col + , padding = padding_ + listMarkerWidth ty + } + ) + ) + ) + ) + ) + + +listMarkerWidth : ListType -> Int +listMarkerWidth listType = + case listType of + Bullet _ -> + 1 + + Numbered _ n -> + if n < 10 then + 2 + + else if n < 100 then + 3 + + else if n < 1000 then + 4 + + else + 5 + + + +-- Parse a bullet and return list type. + + +parseBullet : Parser ListType +parseBullet = + satisfy (\c -> c == '+' || c == '*' || c == '-') + |> bind + (\c -> + unless (c == '+') (nfb (count 2 scanSpaces |> bind (\_ -> skip ((==) c)))) + |> bind + (\_ -> + -- hrule + skipWhile (\x -> x == ' ' || x == c) |> bind (\_ -> endOfInput) + ) + |> bind (\_ -> return (Bullet c)) + ) + + + +-- Parse a list number marker and return list type. + + +parseListNumber : Parser ListType +parseListNumber = + takeWhile1 Char.isDigit + |> bind + (\numStr -> + case String.toInt numStr of + Just num -> + oneOf (fmap (\_ -> PeriodFollowing) (skip ((==) '.'))) (fmap (\_ -> ParenFollowing) (skip ((==) ')'))) + |> bind (\wrap -> return (Numbered wrap num)) + + Nothing -> + crash "Exception: Prelude.read: no parse" + ) + + + +-- ... + + +stripPrefix : String -> String -> Maybe String +stripPrefix p t = + if String.startsWith p t then + Just (String.dropLeft (String.length p) t) + + else + Nothing + + +stringBreak : (Char -> Bool) -> String -> ( String, String ) +stringBreak p t = + List.splitWhen p (String.toList t) + |> Maybe.map (Tuple.mapBoth String.fromList String.fromList) + |> Maybe.withDefault ( t, "" ) + + +stringDropWhileEnd : (Char -> Bool) -> String -> String +stringDropWhileEnd f = + String.reverse + >> stringDropWhile f + >> String.reverse + + +stringDropWhile : (Char -> Bool) -> String -> String +stringDropWhile f str = + case String.uncons str of + Just ( first, rest ) -> + if f first then + stringDropWhile f rest + + else + str + + Nothing -> + "" diff --git a/src/Common/Format/Cheapskate/ParserCombinators.elm b/src/Common/Format/Cheapskate/ParserCombinators.elm new file mode 100644 index 0000000000..6f0a673c4a --- /dev/null +++ b/src/Common/Format/Cheapskate/ParserCombinators.elm @@ -0,0 +1,685 @@ +module Common.Format.Cheapskate.ParserCombinators exposing + ( ParseError(..) + , Parser(..) + , ParserState(..) + , Position(..) + , advance + , anyChar + , apply + , bind + , char + , charClass + , column + , comparePositions + , count + , empty + , endOfInput + , fail + , failure + , fmap + , getPosition + , guard + , inClass + , lazy + , leftSequence + , liftA2 + , lookAhead + , many + , many1 + , manyTill + , mzero + , notAfter + , notFollowedBy + , notInClass + , oneOf + , option + , parse + , peekChar + , peekLastChar + , pure + , return + , satisfy + , scan + , sequence + , setPosition + , showParseError + , showPosition + , skip + , skipMany + , skipMany1 + , skipP + , skipWhile + , string + , stringTakeWhile + , success + , takeText + , takeTill + , takeWhile + , takeWhile1 + , unless + ) + +import Set exposing (Set) + + +type Position + = Position Int Int + + +showPosition : Position -> String +showPosition (Position ln cn) = + "line " ++ String.fromInt ln ++ " column " ++ String.fromInt cn + + +comparePositions : Position -> Position -> Basics.Order +comparePositions (Position ln1 cn1) (Position ln2 cn2) = + if ln1 > ln2 then + GT + + else if ln1 == ln2 then + compare cn1 cn2 + + else + LT + + + +-- the String indicates what the parser was expecting + + +type ParseError + = ParseError Position String + + +showParseError : ParseError -> String +showParseError (ParseError (Position ln cn) msg) = + "ParseError (line " ++ String.fromInt ln ++ " column " ++ String.fromInt cn ++ ") " ++ msg + + +type ParserState + = ParserState + { subject : String + , position : Position + , lastChar : Maybe Char + } + + +advance : ParserState -> String -> ParserState +advance parserState str = + let + go : Char -> ParserState -> ParserState + go c (ParserState st) = + let + (Position line _) = + st.position + in + ParserState + { subject = String.dropLeft 1 st.subject + , position = + case c of + '\n' -> + Position (line + 1) 1 + + _ -> + Position line (column st.position + 1) + , lastChar = Just c + } + in + List.foldl go parserState (String.toList str) + + +type Parser a + = Parser (ParserState -> Result ParseError ( ParserState, a )) + + + +-- instance Functor Parser where + + +fmap : (a -> b) -> Parser a -> Parser b +fmap f (Parser g) = + Parser + (\st -> + case g st of + Ok ( st_, x ) -> + Ok ( st_, f x ) + + Err e -> + Err e + ) + + + +-- instance Applicative Parser where + + +pure : a -> Parser a +pure x = + Parser (\st -> Ok ( st, x )) + + +apply : Parser a -> Parser (a -> b) -> Parser b +apply (Parser g) (Parser f) = + Parser + (\st -> + case f st of + Err e -> + Err e + + Ok ( st_, h ) -> + case g st_ of + Ok ( st__, x ) -> + Ok ( st__, h x ) + + Err e -> + Err e + ) + + +unless : Bool -> Parser () -> Parser () +unless p s = + if p then + pure () + + else + s + + +{-| (<\*) +-} +leftSequence : Parser a -> Parser b -> Parser a +leftSequence p1 p2 = + p1 |> bind (\res -> p2 |> fmap (\_ -> res)) + + + +-- instance Alternative Parser where + + +empty : Parser a +empty = + Parser (\(ParserState st) -> Err (ParseError st.position "(empty)")) + + +guard : Bool -> Parser () +guard bool = + if bool then + pure () + + else + empty + + +oneOf : Parser a -> Parser a -> Parser a +oneOf (Parser f) (Parser g) = + Parser + (\st -> + case f st of + Ok res -> + Ok res + + Err (ParseError pos msg) -> + case g st of + Ok res -> + Ok res + + Err (ParseError pos_ msg_) -> + Err + -- return error for farthest match + (case comparePositions pos pos_ of + LT -> + ParseError pos_ msg_ + + GT -> + ParseError pos msg + + EQ -> + ParseError pos (msg ++ " or " ++ msg_) + ) + ) + + + +-- instance Monad Parser where + + +return : a -> Parser a +return x = + Parser (\st -> Ok ( st, x )) + + +bind : (a -> Parser b) -> Parser a -> Parser b +bind g (Parser p) = + Parser + (\st -> + case p st of + Err e -> + Err e + + Ok ( st_, x ) -> + let + (Parser evalParser) = + g x + in + evalParser st_ + ) + + + +-- instance MonadFail Parser where + + +fail : String -> Parser a +fail e = + Parser (\(ParserState st) -> Err (ParseError st.position e)) + + + +-- instance MonadPlus Parser where + + +mzero : Parser a +mzero = + Parser (\(ParserState st) -> Err (ParseError st.position "(mzero)")) + + +parse : Parser a -> String -> Result ParseError a +parse (Parser evalParser) t = + Result.map Tuple.second + (evalParser + (ParserState + { subject = t + , position = Position 1 1 + , lastChar = Nothing + } + ) + ) + + +failure : ParserState -> String -> Result ParseError ( ParserState, a ) +failure (ParserState st) msg = + Err (ParseError st.position msg) + + +success : ParserState -> a -> Result ParseError ( ParserState, a ) +success st x = + Ok ( st, x ) + + +satisfy : (Char -> Bool) -> Parser Char +satisfy f = + let + g : ParserState -> Result ParseError ( ParserState, Char ) + g (ParserState st) = + case String.uncons st.subject of + Just ( c, _ ) -> + if f c then + success (advance (ParserState st) (String.fromChar c)) c + + else + failure (ParserState st) "character meeting condition" + + _ -> + failure (ParserState st) "character meeting condition" + in + Parser g + + +peekChar : Parser (Maybe Char) +peekChar = + Parser + (\(ParserState st) -> + case String.uncons st.subject of + Just ( c, _ ) -> + success (ParserState st) (Just c) + + Nothing -> + success (ParserState st) Nothing + ) + + +peekLastChar : Parser (Maybe Char) +peekLastChar = + Parser (\(ParserState st) -> success (ParserState st) st.lastChar) + + +notAfter : (Char -> Bool) -> Parser () +notAfter f = + peekLastChar + |> bind + (\mbc -> + case mbc of + Nothing -> + return () + + Just c -> + if f c then + mzero + + else + return () + ) + + + +-- low-grade version of attoparsec's: + + +charClass : String -> Set Char +charClass = + let + go : List Char -> List Char + go str = + case str of + a :: '-' :: b :: xs -> + List.map Char.fromCode (List.range (Char.toCode a) (Char.toCode b)) ++ go xs + + x :: xs -> + x :: go xs + + _ -> + [] + in + Set.fromList << go << String.toList + + +inClass : String -> Char -> Bool +inClass s c = + let + s_ : Set Char + s_ = + charClass s + in + Set.member c s_ + + +notInClass : String -> Char -> Bool +notInClass s = + not << inClass s + + +endOfInput : Parser () +endOfInput = + Parser + (\(ParserState st) -> + if String.isEmpty st.subject then + success (ParserState st) () + + else + failure (ParserState st) "end of input" + ) + + +char : Char -> Parser Char +char c = + satisfy ((==) c) + + +anyChar : Parser Char +anyChar = + satisfy (\_ -> True) + + +getPosition : Parser Position +getPosition = + Parser (\(ParserState st) -> success (ParserState st) st.position) + + +column : Position -> Int +column (Position _ cn) = + cn + + + +-- note: this does not actually change the position in the subject; +-- it only changes what column counts as column N. It is intended +-- to be used in cases where we're parsing a partial line but need to +-- have accurate column information. + + +setPosition : Position -> Parser () +setPosition pos = + Parser (\(ParserState st) -> success (ParserState { st | position = pos }) ()) + + +takeWhile : (Char -> Bool) -> Parser String +takeWhile f = + Parser + (\(ParserState st) -> + let + t : String + t = + stringTakeWhile f st.subject + in + success (advance (ParserState st) t) t + ) + + +takeTill : (Char -> Bool) -> Parser String +takeTill f = + takeWhile (not << f) + + +takeWhile1 : (Char -> Bool) -> Parser String +takeWhile1 f = + Parser + (\(ParserState st) -> + let + t : String + t = + stringTakeWhile f st.subject + in + if String.isEmpty t then + failure (ParserState st) "characters satisfying condition" + + else + success (advance (ParserState st) t) t + ) + + +takeText : Parser String +takeText = + Parser + (\(ParserState st) -> + let + t : String + t = + st.subject + in + success (advance (ParserState st) t) t + ) + + +skip : (Char -> Bool) -> Parser () +skip f = + Parser + (\(ParserState st) -> + case String.uncons st.subject of + Just ( c, _ ) -> + if f c then + success (advance (ParserState st) (String.fromChar c)) () + + else + failure (ParserState st) "character satisfying condition" + + _ -> + failure (ParserState st) "character satisfying condition" + ) + + +skipWhile : (Char -> Bool) -> Parser () +skipWhile f = + Parser + (\(ParserState st) -> + let + t_ : String + t_ = + stringTakeWhile f st.subject + in + success (advance (ParserState st) t_) () + ) + + +string : String -> Parser String +string s = + Parser + (\(ParserState st) -> + if String.startsWith s st.subject then + success (advance (ParserState st) s) s + + else + failure (ParserState st) "string" + ) + + +scan : s -> (s -> Char -> Maybe s) -> Parser String +scan s0 f = + let + go : s -> String -> ParserState -> Result ParseError ( ParserState, String ) + go s cs (ParserState st) = + case String.uncons st.subject of + Nothing -> + finish (ParserState st) cs + + Just ( c, _ ) -> + case f s c of + Just s_ -> + go s_ + (String.cons c cs) + (advance (ParserState st) (String.fromChar c)) + + Nothing -> + finish (ParserState st) cs + + finish : ParserState -> String -> Result ParseError ( ParserState, String ) + finish st cs = + success st (String.reverse cs) + in + Parser (go s0 "") + + +lookAhead : Parser a -> Parser a +lookAhead (Parser p) = + Parser + (\st -> + case p st of + Ok ( _, x ) -> + success st x + + Err _ -> + failure st "lookAhead" + ) + + +notFollowedBy : Parser a -> Parser () +notFollowedBy (Parser p) = + Parser + (\st -> + case p st of + Ok _ -> + failure st "notFollowedBy" + + Err _ -> + success st () + ) + + + +-- combinators (definitions borrowed from attoparsec) + + +option : a -> Parser a -> Parser a +option x p = + oneOf p (pure x) + + +many1 : Parser a -> Parser (List a) +many1 p = + liftA2 (::) p (many p) + + +manyTill : Parser a -> Parser b -> Parser (List a) +manyTill p end = + let + go : () -> Parser (List a) + go () = + oneOf (end |> bind (\_ -> pure [])) (liftA2 (::) p (lazy go)) + in + go () + + +skipMany : Parser a -> Parser () +skipMany p = + many (skipP p) |> fmap (\_ -> ()) + + +skipP : Parser a -> Parser () +skipP p = + p |> fmap (\_ -> ()) + + +skipMany1 : Parser a -> Parser () +skipMany1 p = + p |> bind (\_ -> skipMany p) + + +count : Int -> Parser a -> Parser (List a) +count n p = + sequence (List.repeat n p) + + + +-- ... + + +lazy : (() -> Parser a) -> Parser a +lazy f = + bind f (pure ()) + + +many : Parser a -> Parser (List a) +many (Parser p) = + let + accumulate : List a -> ParserState -> Result ParseError ( ParserState, List a ) + accumulate acc state = + case p state of + Ok ( st_, res ) -> + accumulate (res :: acc) st_ + + Err _ -> + Ok ( state, List.reverse acc ) + in + Parser (accumulate []) + + +liftA2 : (a -> b -> c) -> Parser a -> Parser b -> Parser c +liftA2 f pa pb = + pa + |> fmap f + |> bind (\fApplied -> fmap fApplied pb) + + +sequence : List (Parser a) -> Parser (List a) +sequence parsers = + case parsers of + [] -> + pure [] + + p :: ps -> + liftA2 (::) p (sequence ps) + + +stringTakeWhile : (Char -> Bool) -> String -> String +stringTakeWhile f str = + String.toList str + |> List.foldl + (\c ( found, acc ) -> + if found && f c then + ( True, String.cons c acc ) + + else + ( False, acc ) + ) + ( True, "" ) + |> Tuple.second + |> String.reverse diff --git a/src/Common/Format/Cheapskate/Types.elm b/src/Common/Format/Cheapskate/Types.elm new file mode 100644 index 0000000000..8fa4ddfbba --- /dev/null +++ b/src/Common/Format/Cheapskate/Types.elm @@ -0,0 +1,116 @@ +module Common.Format.Cheapskate.Types exposing + ( Block(..) + , Blocks + , CodeAttr(..) + , Doc(..) + , HtmlTagType(..) + , Inline(..) + , Inlines + , LinkTarget(..) + , ListType(..) + , NumWrapper(..) + , Options(..) + , ReferenceMap + ) + +import Data.Map exposing (Dict) + + + +-- TYPES + + +{-| Structured representation of a document. The 'Options' affect +how the document is rendered by `toHtml`. +-} +type Doc + = Doc Options Blocks + + +{-| Block-level elements. +-} +type Block + = Para Inlines + | Header Int Inlines + | Blockquote Blocks + | List Bool ListType (List Blocks) + | CodeBlock CodeAttr String + | HtmlBlock String + | HRule + | ReferencesBlock (List ( String, String, String )) + | ElmDocs (List (List String)) + + +{-| Attributes for fenced code blocks. 'codeLang' is the +first word of the attribute line, 'codeInfo' is the rest. +-} +type CodeAttr + = CodeAttr + { codeLang : String + , codeInfo : String + } + + +type ListType + = Bullet Char + | Numbered NumWrapper Int + + +type NumWrapper + = PeriodFollowing + | ParenFollowing + + +{-| Simple representation of HTML tag. +-} +type HtmlTagType + = Opening String + | Closing String + | SelfClosing String + + +{-| We operate with sequences instead of lists, because +they allow more efficient appending on to the end. +-} +type alias Blocks = + List Block + + +{-| Inline elements. +-} +type Inline + = Str String + | Space + | SoftBreak + | LineBreak + | Emph Inlines + | Strong Inlines + | Code String + | Link Inlines LinkTarget {- URL -} String {- title -} + | Image Inlines String {- URL -} String {- title -} + | Entity String + | RawHtml String + + +type LinkTarget + = Url String + | Ref String + + +type alias Inlines = + List Inline + + +type alias ReferenceMap = + Dict String String ( String, String ) + + +{-| Rendering and parsing options. +-} +type Options + = Options + { sanitize : Bool -- ^ Sanitize raw HTML, link/image attributes + , allowRawHtml : Bool -- ^ Allow raw HTML (if false it gets escaped) + , preserveHardBreaks : Bool -- ^ Preserve hard line breaks in the source + , debug : Bool -- ^ Print container structure for debugging + } diff --git a/src/Common/Format/Cheapskate/Util.elm b/src/Common/Format/Cheapskate/Util.elm new file mode 100644 index 0000000000..43a8565dc3 --- /dev/null +++ b/src/Common/Format/Cheapskate/Util.elm @@ -0,0 +1,893 @@ +module Common.Format.Cheapskate.Util exposing + ( Scanner + , isEscapable + , isWhitespace + , joinLines + , nfb + , nfbChar + , normalizeReference + , scanBlankline + , scanChar + , scanIndentSpace + , scanNonindentSpace + , scanSpaces + , scanSpacesToColumn + , scanSpnl + , tabFilter + , upToCountChars + ) + +import Common.Format.Cheapskate.ParserCombinators exposing (Parser, bind, char, column, count, endOfInput, fmap, getPosition, notFollowedBy, option, return, scan, skip, skipWhile) +import List.Extra as List +import Utils.Crash exposing (crash) + + + +-- Utility functions. + + +{-| Like T.unlines but does not add a final newline. +Concatenates lines with newlines between. +-} +joinLines : List String -> String +joinLines = + String.join "\n" + + +{-| Convert tabs to spaces using a 4-space tab stop. +-} +tabFilter : String -> String +tabFilter = + let + pad : List String -> List String + pad value = + case value of + [] -> + [] + + [ t ] -> + [ t ] + + t :: ts -> + let + tl : Int + tl = + String.length t + + n : Int + n = + tl + 4 - modBy 4 tl + in + String.padRight n ' ' t :: pad ts + in + String.concat << pad << String.split "\t" + + +{-| These are the whitespace characters that are significant in +parsing markdown. We can treat \\160 (nonbreaking space) etc. +as regular characters. This function should be considerably +faster than the unicode-aware isSpace from Data.Char. +-} +isWhitespace : Char -> Bool +isWhitespace c = + case c of + ' ' -> + True + + '\t' -> + True + + '\n' -> + True + + '\u{000D}' -> + True + + _ -> + False + + +{-| The original Markdown only allowed certain symbols +to be backslash-escaped. It was hard to remember +which ones could be, so we now allow any ascii punctuation mark or +symbol to be escaped, whether or not it has a use in Markdown. +-} +isEscapable : Char -> Bool +isEscapable c = + isAscii c && (isSymbol c || isPunctuation c) + + +{-| Link references are case sensitive and ignore line breaks +and repeated spaces. +-} +normalizeReference : String -> String +normalizeReference = + String.toLower << String.concat << split isWhitespace + + +span_ : (Char -> Bool) -> String -> ( String, String ) +span_ p t = + List.splitWhen p (String.toList t) + |> Maybe.map (Tuple.mapBoth String.fromList String.fromList) + |> Maybe.withDefault ( t, "" ) + + +split : (Char -> Bool) -> String -> List String +split p t = + if String.isEmpty t then + [ "" ] + + else + let + loop : String -> List String + loop s = + let + ( l, s_ ) = + span_ (not << p) s + in + if String.isEmpty s_ then + [ l ] + + else + let + s__ : String + s__ = + case String.uncons s_ of + Just ( _, tail_ ) -> + tail_ + + _ -> + crash "unsafeTail" + in + l :: loop s__ + in + loop t + + +{-| Scanners are implemented here as attoparsec parsers, +which consume input and capture nothing. They could easily +be implemented as regexes in other languages, or hand-coded. +With the exception of scanSpnl, they are all intended to +operate on a single line of input (so endOfInput = endOfLine). +-} +type alias Scanner = + Parser () + + +{-| Scan four spaces. +-} +scanIndentSpace : Scanner +scanIndentSpace = + fmap (\_ -> ()) (count 4 (skip ((==) ' '))) + + +scanSpacesToColumn : Int -> Scanner +scanSpacesToColumn col = + getPosition + |> fmap column + |> bind + (\currentCol -> + let + n : Int + n = + col - currentCol + in + if n >= 1 then + count n (skip ((==) ' ')) + |> fmap (\_ -> ()) + + else + return () + ) + + +{-| Scan 0-3 spaces. +-} +scanNonindentSpace : Scanner +scanNonindentSpace = + fmap (\_ -> ()) (upToCountChars 3 ((==) ' ')) + + +{-| Scan a specified character. +-} +scanChar : Char -> Scanner +scanChar c = + skip ((==) c) |> bind (\_ -> return ()) + + +{-| Scan a blankline. +-} +scanBlankline : Scanner +scanBlankline = + scanSpaces |> bind (\_ -> endOfInput) + + +{-| Scan 0 or more spaces +-} +scanSpaces : Scanner +scanSpaces = + skipWhile ((==) ' ') + + +{-| Scan 0 or more spaces, and optionally a newline +and more spaces. +-} +scanSpnl : Scanner +scanSpnl = + scanSpaces |> bind (\_ -> option () (char '\n' |> bind (\_ -> scanSpaces))) + + +{-| Not followed by: Succeed without consuming input if the specified +scanner would not succeed. +-} +nfb : Parser a -> Scanner +nfb = + notFollowedBy + + +{-| Succeed if not followed by a character. Consumes no input. +-} +nfbChar : Char -> Scanner +nfbChar c = + nfb (skip ((==) c)) + + +upToCountChars : Int -> (Char -> Bool) -> Parser String +upToCountChars cnt f = + scan 0 + (\n c -> + if n < cnt && f c then + Just (n + 1) + + else + Nothing + ) + + +{-| Selects the first 128 characters of the Unicode character set, +corresponding to the ASCII character set. +-} +isAscii : Char -> Bool +isAscii c = + c < '\u{0080}' + + +isSymbol : Char -> Bool +isSymbol c = + String.contains (String.fromChar c) "+-/*=.<>:&|^?%!" + + +{-| Selects Unicode punctuation characters, including various kinds +of connectors, brackets and quotes. + +This function returns 'True' if its argument has one of the +following 'GeneralCategory's, or 'False' otherwise: + + - 'ConnectorPunctuation' + - 'DashPunctuation' + - 'OpenPunctuation' + - 'ClosePunctuation' + - 'InitialQuote' + - 'FinalQuote' + - 'OtherPunctuation' + +These classes are defined in the +< Unicode Character Database>, +part of the Unicode standard. The same document defines what is +and is not a "Punctuation". + +-} +isPunctuation : Char -> Bool +isPunctuation c = + List.member (Char.toCode c) + [ 0x21 + , 0x22 + , 0x23 + , 0x25 + , 0x26 + , 0x27 + , 0x28 + , 0x29 + , 0x2A + , 0x2C + , 0x2D + , 0x2E + , 0x2F + , 0x3A + , 0x3B + , 0x3F + , 0x40 + , 0x5B + , 0x5C + , 0x5D + , 0x5F + , 0x7B + , 0x7D + , 0xA1 + , 0xA7 + , 0xAB + , 0xB6 + , 0xB7 + , 0xBB + , 0xBF + , 0x037E + , 0x0387 + , 0x055A + , 0x055B + , 0x055C + , 0x055D + , 0x055E + , 0x055F + , 0x0589 + , 0x058A + , 0x05BE + , 0x05C0 + , 0x05C3 + , 0x05C6 + , 0x05F3 + , 0x05F4 + , 0x0609 + , 0x060A + , 0x060C + , 0x060D + , 0x061B + , 0x061E + , 0x061F + , 0x066A + , 0x066B + , 0x066C + , 0x066D + , 0x06D4 + , 0x0700 + , 0x0701 + , 0x0702 + , 0x0703 + , 0x0704 + , 0x0705 + , 0x0706 + , 0x0707 + , 0x0708 + , 0x0709 + , 0x070A + , 0x070B + , 0x070C + , 0x070D + , 0x07F7 + , 0x07F8 + , 0x07F9 + , 0x0830 + , 0x0831 + , 0x0832 + , 0x0833 + , 0x0834 + , 0x0835 + , 0x0836 + , 0x0837 + , 0x0838 + , 0x0839 + , 0x083A + , 0x083B + , 0x083C + , 0x083D + , 0x083E + , 0x085E + , 0x0964 + , 0x0965 + , 0x0970 + , 0x09FD + , 0x0A76 + , 0x0AF0 + , 0x0C77 + , 0x0C84 + , 0x0DF4 + , 0x0E4F + , 0x0E5A + , 0x0E5B + , 0x0F04 + , 0x0F05 + , 0x0F06 + , 0x0F07 + , 0x0F08 + , 0x0F09 + , 0x0F0A + , 0x0F0B + , 0x0F0C + , 0x0F0D + , 0x0F0E + , 0x0F0F + , 0x0F10 + , 0x0F11 + , 0x0F12 + , 0x0F14 + , 0x0F3A + , 0x0F3B + , 0x0F3C + , 0x0F3D + , 0x0F85 + , 0x0FD0 + , 0x0FD1 + , 0x0FD2 + , 0x0FD3 + , 0x0FD4 + , 0x0FD9 + , 0x0FDA + , 0x104A + , 0x104B + , 0x104C + , 0x104D + , 0x104E + , 0x104F + , 0x10FB + , 0x1360 + , 0x1361 + , 0x1362 + , 0x1363 + , 0x1364 + , 0x1365 + , 0x1366 + , 0x1367 + , 0x1368 + , 0x1400 + , 0x166E + , 0x169B + , 0x169C + , 0x16EB + , 0x16EC + , 0x16ED + , 0x1735 + , 0x1736 + , 0x17D4 + , 0x17D5 + , 0x17D6 + , 0x17D8 + , 0x17D9 + , 0x17DA + , 0x1800 + , 0x1801 + , 0x1802 + , 0x1803 + , 0x1804 + , 0x1805 + , 0x1806 + , 0x1807 + , 0x1808 + , 0x1809 + , 0x180A + , 0x1944 + , 0x1945 + , 0x1A1E + , 0x1A1F + , 0x1AA0 + , 0x1AA1 + , 0x1AA2 + , 0x1AA3 + , 0x1AA4 + , 0x1AA5 + , 0x1AA6 + , 0x1AA8 + , 0x1AA9 + , 0x1AAA + , 0x1AAB + , 0x1AAC + , 0x1AAD + , 0x1B5A + , 0x1B5B + , 0x1B5C + , 0x1B5D + , 0x1B5E + , 0x1B5F + , 0x1B60 + , 0x1BFC + , 0x1BFD + , 0x1BFE + , 0x1BFF + , 0x1C3B + , 0x1C3C + , 0x1C3D + , 0x1C3E + , 0x1C3F + , 0x1C7E + , 0x1C7F + , 0x1CC0 + , 0x1CC1 + , 0x1CC2 + , 0x1CC3 + , 0x1CC4 + , 0x1CC5 + , 0x1CC6 + , 0x1CC7 + , 0x1CD3 + , 0x2010 + , 0x2011 + , 0x2012 + , 0x2013 + , 0x2014 + , 0x2015 + , 0x2016 + , 0x2017 + , 0x2018 + , 0x2019 + , 0x201A + , 0x201B + , 0x201C + , 0x201D + , 0x201E + , 0x201F + , 0x2020 + , 0x2021 + , 0x2022 + , 0x2023 + , 0x2024 + , 0x2025 + , 0x2026 + , 0x2027 + , 0x2030 + , 0x2031 + , 0x2032 + , 0x2033 + , 0x2034 + , 0x2035 + , 0x2036 + , 0x2037 + , 0x2038 + , 0x2039 + , 0x203A + , 0x203B + , 0x203C + , 0x203D + , 0x203E + , 0x203F + , 0x2040 + , 0x2041 + , 0x2042 + , 0x2043 + , 0x2045 + , 0x2046 + , 0x2047 + , 0x2048 + , 0x2049 + , 0x204A + , 0x204B + , 0x204C + , 0x204D + , 0x204E + , 0x204F + , 0x2050 + , 0x2051 + , 0x2053 + , 0x2054 + , 0x2055 + , 0x2056 + , 0x2057 + , 0x2058 + , 0x2059 + , 0x205A + , 0x205B + , 0x205C + , 0x205D + , 0x205E + , 0x207D + , 0x207E + , 0x208D + , 0x208E + , 0x2308 + , 0x2309 + , 0x230A + , 0x230B + , 0x2329 + , 0x232A + , 0x2768 + , 0x2769 + , 0x276A + , 0x276B + , 0x276C + , 0x276D + , 0x276E + , 0x276F + , 0x2770 + , 0x2771 + , 0x2772 + , 0x2773 + , 0x2774 + , 0x2775 + , 0x27C5 + , 0x27C6 + , 0x27E6 + , 0x27E7 + , 0x27E8 + , 0x27E9 + , 0x27EA + , 0x27EB + , 0x27EC + , 0x27ED + , 0x27EE + , 0x27EF + , 0x2983 + , 0x2984 + , 0x2985 + , 0x2986 + , 0x2987 + , 0x2988 + , 0x2989 + , 0x298A + , 0x298B + , 0x298C + , 0x298D + , 0x298E + , 0x298F + , 0x2990 + , 0x2991 + , 0x2992 + , 0x2993 + , 0x2994 + , 0x2995 + , 0x2996 + , 0x2997 + , 0x2998 + , 0x29D8 + , 0x29D9 + , 0x29DA + , 0x29DB + , 0x29FC + , 0x29FD + , 0x2CF9 + , 0x2CFA + , 0x2CFB + , 0x2CFC + , 0x2CFE + , 0x2CFF + , 0x2D70 + , 0x2E00 + , 0x2E01 + , 0x2E02 + , 0x2E03 + , 0x2E04 + , 0x2E05 + , 0x2E06 + , 0x2E07 + , 0x2E08 + , 0x2E09 + , 0x2E0A + , 0x2E0B + , 0x2E0C + , 0x2E0D + , 0x2E0E + , 0x2E0F + , 0x2E10 + , 0x2E11 + , 0x2E12 + , 0x2E13 + , 0x2E14 + , 0x2E15 + , 0x2E16 + , 0x2E17 + , 0x2E18 + , 0x2E19 + , 0x2E1A + , 0x2E1B + , 0x2E1C + , 0x2E1D + , 0x2E1E + , 0x2E1F + , 0x2E20 + , 0x2E21 + , 0x2E22 + , 0x2E23 + , 0x2E24 + , 0x2E25 + , 0x2E26 + , 0x2E27 + , 0x2E28 + , 0x2E29 + , 0x2E2A + , 0x2E2B + , 0x2E2C + , 0x2E2D + , 0x2E2E + , 0x2E30 + , 0x2E31 + , 0x2E32 + , 0x2E33 + , 0x2E34 + , 0x2E35 + , 0x2E36 + , 0x2E37 + , 0x2E38 + , 0x2E39 + , 0x2E3A + , 0x2E3B + , 0x2E3C + , 0x2E3D + , 0x2E3E + , 0x2E3F + , 0x2E40 + , 0x2E41 + , 0x2E42 + , 0x2E43 + , 0x2E44 + , 0x2E45 + , 0x2E46 + , 0x2E47 + , 0x2E48 + , 0x2E49 + , 0x2E4A + , 0x2E4B + , 0x2E4C + , 0x2E4D + , 0x2E4E + , 0x2E4F + , 0x3001 + , 0x3002 + , 0x3003 + , 0x3008 + , 0x3009 + , 0x300A + , 0x300B + , 0x300C + , 0x300D + , 0x300E + , 0x300F + , 0x3010 + , 0x3011 + , 0x3014 + , 0x3015 + , 0x3016 + , 0x3017 + , 0x3018 + , 0x3019 + , 0x301A + , 0x301B + , 0x301C + , 0x301D + , 0x301E + , 0x301F + , 0x3030 + , 0x303D + , 0x30A0 + , 0x30FB + , 0xA4FE + , 0xA4FF + , 0xA60D + , 0xA60E + , 0xA60F + , 0xA673 + , 0xA67E + , 0xA6F2 + , 0xA6F3 + , 0xA6F4 + , 0xA6F5 + , 0xA6F6 + , 0xA6F7 + , 0xA874 + , 0xA875 + , 0xA876 + , 0xA877 + , 0xA8CE + , 0xA8CF + , 0xA8F8 + , 0xA8F9 + , 0xA8FA + , 0xA8FC + , 0xA92E + , 0xA92F + , 0xA95F + , 0xA9C1 + , 0xA9C2 + , 0xA9C3 + , 0xA9C4 + , 0xA9C5 + , 0xA9C6 + , 0xA9C7 + , 0xA9C8 + , 0xA9C9 + , 0xA9CA + , 0xA9CB + , 0xA9CC + , 0xA9CD + , 0xA9DE + , 0xA9DF + , 0xAA5C + , 0xAA5D + , 0xAA5E + , 0xAA5F + , 0xAADE + , 0xAADF + , 0xAAF0 + , 0xAAF1 + , 0xABEB + , 0xFD3E + , 0xFD3F + , 0xFE10 + , 0xFE11 + , 0xFE12 + , 0xFE13 + , 0xFE14 + , 0xFE15 + , 0xFE16 + , 0xFE17 + , 0xFE18 + , 0xFE19 + , 0xFE30 + , 0xFE31 + , 0xFE32 + , 0xFE33 + , 0xFE34 + , 0xFE35 + , 0xFE36 + , 0xFE37 + , 0xFE38 + , 0xFE39 + , 0xFE3A + , 0xFE3B + , 0xFE3C + , 0xFE3D + , 0xFE3E + , 0xFE3F + , 0xFE40 + , 0xFE41 + , 0xFE42 + , 0xFE43 + , 0xFE44 + , 0xFE45 + , 0xFE46 + , 0xFE47 + , 0xFE48 + , 0xFE49 + , 0xFE4A + , 0xFE4B + , 0xFE4C + , 0xFE4D + , 0xFE4E + , 0xFE4F + , 0xFE50 + , 0xFE51 + , 0xFE52 + , 0xFE54 + , 0xFE55 + , 0xFE56 + , 0xFE57 + , 0xFE58 + , 0xFE59 + , 0xFE5A + , 0xFE5B + , 0xFE5C + , 0xFE5D + , 0xFE5E + , 0xFE5F + , 0xFE60 + , 0xFE61 + , 0xFE63 + , 0xFE68 + , 0xFE6A + , 0xFE6B + , 0xFF01 + , 0xFF02 + , 0xFF03 + , 0xFF05 + , 0xFF06 + , 0xFF07 + , 0xFF08 + , 0xFF09 + , 0xFF0A + , 0xFF0C + , 0xFF0D + , 0xFF0E + , 0xFF0F + , 0xFF1A + , 0xFF1B + , 0xFF1F + , 0xFF20 + , 0xFF3B + , 0xFF3C + , 0xFF3D + , 0xFF3F + , 0xFF5B + , 0xFF5D + , 0xFF5F + , 0xFF60 + , 0xFF61 + , 0xFF62 + , 0xFF63 + , 0xFF64 + , 0xFF65 + ] diff --git a/src/Common/Format/ImportInfo.elm b/src/Common/Format/ImportInfo.elm new file mode 100644 index 0000000000..ccd73ede4d --- /dev/null +++ b/src/Common/Format/ImportInfo.elm @@ -0,0 +1,201 @@ +module Common.Format.ImportInfo exposing + ( ImportInfo(..) + , fromImports + , fromModule + , importsToDict + ) + +import Basics.Extra exposing (flip) +import Common.Format.Bimap as Bimap exposing (Bimap) +import Common.Format.KnownContents as KnownContents exposing (KnownContents) +import Compiler.AST.Source as Src +import Compiler.Elm.Compiler.Imports as Imports +import Compiler.Parse.Module as M +import Compiler.Reporting.Annotation as A +import Data.Map as Dict exposing (Dict) +import Data.Set as EverySet exposing (EverySet) + + +type ImportInfo + = ImportInfo + { exposed : Dict String String String + , aliases : Bimap String String + , directImports : EverySet String String + , ambiguous : Dict String String (List String) + , unresolvedExposingAll : EverySet String String -- any modules with exposing(..) and we didn't know the module contents + } + + +fromModule : KnownContents -> M.Module -> ImportInfo +fromModule knownContents modu = + let + ( _, imports ) = + modu.imports + in + fromImports knownContents (importsToDict (List.map Src.c1Value imports)) + + +importsToDict : List Src.Import -> Dict String String Src.Import +importsToDict = + List.map (\((Src.Import ( _, A.At _ name ) _ _) as import_) -> ( name, import_ )) + >> Dict.fromList identity + + +fromImports : KnownContents -> Dict String String Src.Import -> ImportInfo +fromImports knownContents rawImports = + let + defaultImports : Dict String String Src.Import + defaultImports = + -- TODO check if we need to have only these 3: Basics, List, Maybe + -- [ ( [ "Basics" ], OpenListing (C ( [], [] ) ()) ) + -- , ( [ "List" ], ClosedListing ) + -- , ( [ "Maybe" ] + -- , ExplicitListing + -- (DetailedListing mempty mempty <| + -- Dict.fromList + -- [ ( UppercaseIdentifier "Maybe" + -- , C ( [], [] ) <| + -- C [] <| + -- ExplicitListing + -- (Dict.fromList + -- [ ( UppercaseIdentifier "Nothing", C ( [], [] ) () ) + -- , ( UppercaseIdentifier "Just", C ( [], [] ) () ) + -- ] + -- ) + -- False + -- ) + -- ] + -- ) + -- False + -- ) + -- ] + importsToDict (List.map Src.c1Value Imports.defaults) + + imports : Dict String String Src.Import + imports = + Dict.union rawImports defaultImports + + -- NOTE: this MUST prefer rawImports when there is a duplicate key + -- these are things we know will get exposed for certain modules when we see "exposing (..)" + -- only things that are currently useful for Elm 0.19 upgrade are included + moduleContents : String -> List String + moduleContents moduleName = + case moduleName of + "Basics" -> + [ "identity" + ] + + "Html.Attributes" -> + [ "style" + ] + + "List" -> + [ "filterMap" + ] + + "Maybe" -> + [ "Nothing" + , "Just" + ] + + _ -> + KnownContents.get moduleName knownContents + |> Maybe.withDefault [] + + getExposed : String -> Src.Import -> Dict String String String + getExposed moduleName (Src.Import _ _ ( _, exposing_ )) = + Dict.fromList identity <| + List.map (flip Tuple.pair moduleName) <| + case exposing_ of + Src.Open _ _ -> + moduleContents moduleName + + Src.Explicit _ -> + -- TODO + -- (fmap VarName <| Dict.keys <| AST.Module.values details) + -- <> (fmap TypeName <| Dict.keys <| AST.Module.types details) + -- <> (fmap CtorName <| foldMap (getCtorListings << extract << extract) <| Dict.elems <| AST.Module.types details) + [] + + -- getCtorListings : Listing (CommentedMap name ()) -> List name + -- getCtorListings listing = + -- case listing of + -- ClosedListing -> + -- [] + -- OpenListing _ -> + -- -- TODO: exposing (Type(..)) should pull in variant names from knownContents, though this should also be a warning because we can't know for sure which of those are for this type + -- [] + -- ExplicitListing ctors _ -> + -- Dict.keys ctors + exposed : Dict String String String + exposed = + -- TODO: mark ambiguous names if multiple modules expose them + Dict.foldl compare (\k v a -> Dict.union a <| getExposed k v) Dict.empty imports + + aliases : Bimap String String + aliases = + let + getAlias : Src.Import -> Maybe String + getAlias (Src.Import _ maybeAlias _) = + Maybe.map Src.c2Value maybeAlias + + liftMaybe : ( a, Maybe b ) -> Maybe ( a, b ) + liftMaybe value = + case value of + ( _, Nothing ) -> + Nothing + + ( a, Just b ) -> + Just ( a, b ) + in + Dict.toList compare imports + |> List.map (Tuple.mapSecond getAlias) + |> List.filterMap liftMaybe + |> List.map (\( a, b ) -> ( b, a )) + |> Bimap.fromList identity identity + + noAlias : Src.Import -> Bool + noAlias (Src.Import _ maybeAlias _) = + case maybeAlias of + Just _ -> + False + + Nothing -> + True + + directs : EverySet String String + directs = + EverySet.union + (EverySet.singleton identity "Basics") + (Dict.filter (\_ -> noAlias) imports + |> Dict.keys compare + |> EverySet.fromList identity + ) + + ambiguous : Dict String String (List String) + ambiguous = + Dict.empty + + exposesAll : Src.Import -> Bool + exposesAll (Src.Import _ _ ( _, exposing_ )) = + case exposing_ of + Src.Open _ _ -> + True + + Src.Explicit _ -> + False + + unresolvedExposingAll : EverySet String String + unresolvedExposingAll = + Dict.filter (\_ -> exposesAll) rawImports + |> Dict.keys compare + |> EverySet.fromList identity + |> EverySet.filter (not << KnownContents.isKnown knownContents) + in + ImportInfo + { exposed = exposed + , aliases = aliases + , directImports = directs + , ambiguous = ambiguous + , unresolvedExposingAll = unresolvedExposingAll + } diff --git a/src/Common/Format/KnownContents.elm b/src/Common/Format/KnownContents.elm new file mode 100644 index 0000000000..a2d3970996 --- /dev/null +++ b/src/Common/Format/KnownContents.elm @@ -0,0 +1,38 @@ +module Common.Format.KnownContents exposing + ( KnownContents + , fromFunction + , get + , isKnown + , mempty + ) + +import Maybe.Extra as Maybe + + +type KnownContents + = KnownContents (String -> Maybe (List String)) -- return Nothing if the contents are unknown + + + +-- instance Semigroup KnownContents where +-- (KnownContents a) <> (KnownContents b) = KnownContents (\ns -> a ns <> b ns) + + +mempty : KnownContents +mempty = + fromFunction (always Nothing) + + +fromFunction : (String -> Maybe (List String)) -> KnownContents +fromFunction = + KnownContents + + +isKnown : KnownContents -> String -> Bool +isKnown (KnownContents lookup) = + Maybe.unwrap False (always True) << lookup + + +get : String -> KnownContents -> Maybe (List String) +get ns (KnownContents lookup) = + lookup ns diff --git a/src/Common/Format/RWS.elm b/src/Common/Format/RWS.elm new file mode 100644 index 0000000000..17b572e7b0 --- /dev/null +++ b/src/Common/Format/RWS.elm @@ -0,0 +1,109 @@ +module Common.Format.RWS exposing + ( RWS + , bind + , error + , evalRWS + , get + , mapM_ + , modify + , put + , replicateM + , return + , runRWS + , tell + ) + +import Data.Map as Dict exposing (Dict) +import Utils.Crash exposing (crash) + + +type alias RWS r s a = + -- type alias RWS r w s a = + -- r: (), w: ReferenceMap, s: ContainerStack, a: Container + r -> s -> ( a, s, Dict String String ( String, String ) ) + + +evalRWS : RWS r s a -> r -> s -> ( a, Dict String String ( String, String ) ) +evalRWS rws r s = + let + ( a, _, w ) = + runRWS rws r s + in + ( a, w ) + + +runRWS : RWS r s a -> r -> s -> ( a, s, Dict String String ( String, String ) ) +runRWS rws r s = + rws r s + + +mapM_ : (a -> RWS r s b) -> List a -> RWS r s () +mapM_ f xs = + \r s0 -> + List.foldr + (\x ( _, s, w ) -> + let + ( _, newS, newW ) = + f x r s + in + ( (), newS, Dict.union w newW ) + ) + ( (), s0, Dict.empty ) + xs + + +bind : (a -> RWS r s b) -> RWS r s a -> RWS r s b +bind f rwsa = + \r s0 -> + let + ( a, s1, w1 ) = + rwsa r s0 + + ( b, s2, w2 ) = + f a r s1 + in + ( b, s2, Dict.union w1 w2 ) + + +get : RWS r s s +get = + \_ s -> ( s, s, Dict.empty ) + + +put : s -> RWS r s () +put newState = + \_ _ -> ( (), newState, Dict.empty ) + + +modify : (s -> s) -> RWS r s () +modify f = + \_ s -> ( (), f s, Dict.empty ) + + +return : a -> RWS r s a +return a = + \_ s -> ( a, s, Dict.empty ) + + +tell : Dict String String ( String, String ) -> RWS r s () +tell log = + \_ s -> ( (), s, log ) + + +replicateM : Int -> RWS r s a -> RWS r s (List a) +replicateM n rws = + if n <= 0 then + return [] + + else + rws + |> bind + (\a -> + replicateM (n - 1) rws + |> bind (\list -> return (a :: list)) + ) + + +error : String -> RWS r s a +error = + crash diff --git a/src/Common/Format/Render/Box.elm b/src/Common/Format/Render/Box.elm new file mode 100644 index 0000000000..b7eeb382a3 --- /dev/null +++ b/src/Common/Format/Render/Box.elm @@ -0,0 +1,3173 @@ +module Common.Format.Render.Box exposing (formatModule) + +import Basics.Extra exposing (flip) +import Common.Format.Box as Box exposing (Box) +import Common.Format.Cheapskate.Parse as Parse +import Common.Format.Cheapskate.Types exposing (Block(..), Blocks, Doc(..), LinkTarget(..), Options(..)) +import Common.Format.ImportInfo as ImportInfo exposing (ImportInfo) +import Common.Format.KnownContents as KnownContents +import Common.Format.Render.ElmStructure as ElmStructure +import Common.Format.Render.Markdown as Markdown +import Compiler.AST.Source as Src +import Compiler.AST.Utils.Binop as Binop +import Compiler.AST.Utils.Shader as Shader +import Compiler.Data.Name exposing (Name) +import Compiler.Parse.Declaration as Decl +import Compiler.Parse.Expression as Expr +import Compiler.Parse.Module as M +import Compiler.Parse.Primitives as P +import Compiler.Parse.SyntaxVersion as SV +import Compiler.Reporting.Annotation as A +import Data.Map as Map exposing (Dict) +import Data.Set as EverySet exposing (EverySet) +import Hex +import Maybe.Extra as Maybe +import Utils.Crash exposing (crash) + + +type alias Module = + { importInfo : ImportInfo + , initialComments : Src.FComments + , header : Maybe Header + , docs : A.Located (Maybe Blocks) + , imports : Src.C1 (Dict (List String) (List Name) (Src.C1 ImportMethod)) + , body : List (TopLevelStructure Declaration) + } + + +type Header + = Header SourceTag (Src.C2 (List Name)) (Maybe (Src.C2 SourceSettings)) (Maybe (Src.C2 (Listing DetailedListing))) + + +defaultHeader : Header +defaultHeader = + Header Normal ( ( [], [] ), [ "Main" ] ) Nothing Nothing + + +type alias SourceSettings = + List ( Src.C2 Name, Src.C2 Name ) + + +type SourceTag + = Normal + | Effect Src.FComments + | Port Src.FComments + + +type alias UserImport = + ( Src.C1 (List Name), ImportMethod ) + + +type ImportMethod + = ImportMethod (Maybe (Src.C2 Name)) (Src.C2 (Listing DetailedListing)) + + +{-| A listing of values. Something like (a,b,c) or (..) or (a,b,..) +-} +type Listing a + = ExplicitListing a Bool + | OpenListing (Src.C2 ()) + | ClosedListing + + +type alias DetailedListing = + { values : CommentedMap Name () + , operators : CommentedMap Name () + , types : CommentedMap Name (Src.C1 (Listing (CommentedMap Name ()))) + } + + +type alias CommentedMap k v = + Dict String k (Src.C2 v) + + +{-| A value that can be imported or exported +-} +type Value + = Value Name + | OpValue Name + | Union (Src.C1 Name) (Listing (CommentedMap Name ())) + + +type Declaration + = CommonDeclaration CommonDeclaration + | Datatype (Src.C2 (NameWithArgs Name Name)) (Src.OpenCommentedList (NameWithArgs Name Src.Type)) + | TypeAlias Src.FComments (Src.C2 (NameWithArgs Name Name)) (Src.C1 Src.Type) + | PortAnnotation (Src.C2 Name) Src.FComments Src.Type + | Fixity (Src.C1 Binop.Associativity) (Src.C1 Binop.Precedence) (Src.C2 Name) (Src.C1 Name) + + +type CommonDeclaration + = Definition Src.Pattern (List (Src.C1 Src.Pattern)) Src.FComments Src.Expr + | TypeAnnotation (Src.C1 (Ref ())) (Src.C1 Src.Type) + + +type NameWithArgs name arg + = NameWithArgs name (List (Src.C1 arg)) + + +type TopLevelStructure a + = DocComment Blocks + | BodyComment Src.FComment + | Entry a + + +topLevelStructureMap : (a -> b) -> TopLevelStructure a -> TopLevelStructure b +topLevelStructureMap f topLevelStructure = + case topLevelStructure of + DocComment blocks -> + DocComment blocks + + BodyComment comment -> + BodyComment comment + + Entry a -> + Entry (f a) + + +type Ref ns + = VarRef ns String + | TagRef ns String + | OpRef String + + +refMap : (a -> b) -> Ref a -> Ref b +refMap f ref = + case ref of + VarRef namespace name -> + VarRef (f namespace) name + + TagRef namespace name -> + TagRef (f namespace) name + + OpRef name -> + OpRef name + + +pairs : List a -> List ( a, a ) +pairs input = + let + step : a -> ( Maybe b, List ( a, b ) ) -> ( Maybe a, List ( a, b ) ) + step next ( prev, acc ) = + case prev of + Nothing -> + ( Just next, acc ) + + Just prev_ -> + ( Just next, ( next, prev_ ) :: acc ) + in + List.foldr step ( Nothing, [] ) input + |> Tuple.second + + +intersperseMap : (a -> a -> List b) -> (a -> b) -> List a -> List b +intersperseMap spacer fn list = + case list of + [] -> + [] + + first :: _ -> + fn first + :: (pairs list + |> List.concatMap (\( a, b ) -> spacer a b ++ [ fn b ]) + ) + + +pleaseReport__ : String -> String -> String +pleaseReport__ what details = + -- TODO: include version in the message + "" + + +pleaseReport_ : String -> String -> Box.Line +pleaseReport_ what details = + Box.keyword (pleaseReport__ what details) + + +pleaseReport : String -> String -> Box +pleaseReport what details = + Box.line (pleaseReport_ what details) + + +surround : Char -> Char -> Box -> Box +surround left right b = + let + left_ : Box.Line + left_ = + Box.punc (String.fromChar left) + + right_ : Box.Line + right_ = + Box.punc (String.fromChar right) + in + case b of + Box.SingleLine b_ -> + Box.line (Box.row [ left_, b_, right_ ]) + + _ -> + Box.stack1 + [ Box.prefix left_ b + , Box.line right_ + ] + + +parens : Box -> Box +parens = + surround '(' ')' + + +formatBinary : Bool -> Box -> List ( ( Bool, Src.FComments, Box ), Box ) -> Box +formatBinary multiline left ops = + case ops of + [] -> + left + + ( ( isLeftPipe, comments, op ), next ) :: rest -> + if isLeftPipe then + ElmStructure.forceableSpaceSepOrIndented multiline + (ElmStructure.spaceSepOrStack left + (List.concat + [ Maybe.toList <| formatComments comments + , [ op ] + ] + ) + ) + [ formatBinary multiline next rest ] + + else + formatBinary + multiline + (ElmStructure.forceableSpaceSepOrIndented multiline left [ formatCommentedApostrophe comments (ElmStructure.spaceSepOrPrefix op next) ]) + rest + + +type DeclarationType + = DComment + | DStarter + | DCloser + | DDefinition (Maybe (Ref ())) + | DFixity + | DDocComment + + +declarationType : TopLevelStructure BodyEntryType -> DeclarationType +declarationType decl = + case decl of + Entry entry -> + case entry of + BodyNamed name -> + DDefinition (Just name) + + BodyUnnamed -> + DDefinition Nothing + + BodyFixity -> + DFixity + + DocComment _ -> + DDocComment + + BodyComment Src.CommentTrickOpener -> + DStarter + + BodyComment Src.CommentTrickCloser -> + DCloser + + BodyComment _ -> + DComment + + +removeDuplicates : List (List (Src.C2 Value)) -> List (List (Src.C2 Value)) +removeDuplicates input = + let + step : + List (Src.C2 Value) + -> ( List (List (Src.C2 Value)), EverySet String (Src.C2 Value) ) + -> ( List (List (Src.C2 Value)), EverySet String (Src.C2 Value) ) + step next ( acc, seen ) = + case List.foldl stepChildren ( [], seen ) next |> (\( a, b ) -> ( List.reverse a, b )) of + ( [], seen_ ) -> + ( acc, seen_ ) + + ( children_, seen_ ) -> + ( children_ :: acc, seen_ ) + + varName : Src.C2 Value -> Name + varName var = + case var of + ( _, Value name ) -> + name + + ( _, OpValue name ) -> + name + + ( _, Union ( _, name ) _ ) -> + name + + stepChildren : + Src.C2 Value + -> ( List (Src.C2 Value), EverySet String (Src.C2 Value) ) + -> ( List (Src.C2 Value), EverySet String (Src.C2 Value) ) + stepChildren next ( acc, seen ) = + if EverySet.member varName next seen then + ( acc, seen ) + + else + ( next :: acc, EverySet.insert varName next seen ) + in + List.foldl step ( [], EverySet.empty ) input + |> Tuple.first + |> List.reverse + + +sortVars : Bool -> EverySet String (Src.C2 Value) -> List (List String) -> ( List (List (Src.C2 Value)), Src.FComments ) +sortVars forceMultiline fromExposing fromDocs = + let + varOrder : Src.C2 Value -> ( Int, String ) + varOrder ( _, value ) = + case value of + OpValue name -> + ( 1, name ) + + Union ( _, name ) _ -> + ( 2, name ) + + Value name -> + ( 3, name ) + + listedInDocs : List (List (Src.C2 Value)) + listedInDocs = + fromDocs + |> List.map (List.filterMap (\v -> Map.get identity v allowedInDocs)) + |> List.filter (not << List.isEmpty) + |> List.map (List.map (Tuple.pair ( [], [] ))) + |> removeDuplicates + + listedInExposing : List (Src.C2 Value) + listedInExposing = + fromExposing + |> EverySet.toList (\a b -> compare (varName a) (varName b)) + |> List.sortBy varOrder + + varName : Src.C2 Value -> String + varName ( _, value ) = + case value of + Value name -> + name + + OpValue name -> + name + + Union ( _, name ) _ -> + name + + varSetToMap : EverySet String (Src.C2 Value) -> Dict String String Value + varSetToMap set = + EverySet.toList (\a b -> compare (varName a) (varName b)) set + |> List.map (\( c, var ) -> ( varName ( c, var ), var )) + |> Map.fromList identity + + allowedInDocs : Dict String String Value + allowedInDocs = + varSetToMap fromExposing + + allFromDocs : EverySet String String + allFromDocs = + EverySet.fromList identity <| List.map varName <| List.concat listedInDocs + + inDocs : Src.C2 Value -> Bool + inDocs x = + EverySet.member identity (varName x) allFromDocs + + remainingFromExposing : List (Src.C2 Value) + remainingFromExposing = + listedInExposing + |> List.filter (not << inDocs) + + commentsFromReorderedVars : Src.FComments + commentsFromReorderedVars = + listedInExposing + |> List.filter inDocs + |> List.concatMap (\( ( pre, post ), _ ) -> pre ++ post) + in + if List.isEmpty listedInDocs && forceMultiline then + ( List.map (\x -> [ x ]) remainingFromExposing, commentsFromReorderedVars ) + + else + ( listedInDocs + ++ (if List.isEmpty remainingFromExposing then + [] + + else + [ remainingFromExposing ] + ) + , commentsFromReorderedVars + ) + + +formatModuleHeader : Bool -> Module -> List Box +formatModuleHeader addDefaultHeader modu = + let + maybeHeader : Maybe Header + maybeHeader = + if addDefaultHeader then + Just (Maybe.withDefault defaultHeader modu.header) + + else + modu.header + + refName : Ref (List String) -> String + refName ref = + case ref of + VarRef _ name -> + name + + TagRef _ name -> + name + + OpRef name -> + name + + varName : Src.C2 Value -> Name + varName var = + case var of + ( _, Value name ) -> + name + + ( _, OpValue name ) -> + name + + ( _, Union ( _, name ) _ ) -> + name + + documentedVars : List (List String) + documentedVars = + modu.docs + |> A.toValue + |> Maybe.withDefault [] + |> List.concatMap extractDocs + + extractDocs : Block -> List (List String) + extractDocs block = + case block of + ElmDocs vars -> + List.map (List.map (refName << textToRef)) vars + + _ -> + [] + + textToRef : String -> Ref (List String) + textToRef text = + case String.toList text of + (c :: _) as s -> + if Char.isUpper c then + TagRef [] text + + else if Char.isLower c then + VarRef [] text + + else + case s of + [ '(', a, ')' ] -> + OpRef (String.fromChar a) + + [ '(', a, b, ')' ] -> + OpRef (String.fromList [ a, b ]) + + _ -> + VarRef [] text + + _ -> + VarRef [] text + + exportsList : Listing DetailedListing + exportsList = + case Maybe.withDefault defaultHeader maybeHeader of + Header _ _ _ (Just ( _, e )) -> + e + + Header _ _ _ Nothing -> + ClosedListing + + detailedListingToSet : Listing DetailedListing -> EverySet String (Src.C2 Value) + detailedListingToSet value = + case value of + OpenListing _ -> + EverySet.empty + + ClosedListing -> + EverySet.empty + + ExplicitListing { values, operators, types } _ -> + let + toComparable : Src.C2 Value -> Name + toComparable ( _, v ) = + case v of + OpValue name -> + name + + Union ( _, name ) _ -> + name + + Value name -> + name + in + List.foldl EverySet.union EverySet.empty <| + [ Map.toList compare values |> List.map (\( name, ( c, () ) ) -> ( c, Value name )) |> EverySet.fromList toComparable + , Map.toList compare operators |> List.map (\( name, ( c, () ) ) -> ( c, OpValue name )) |> EverySet.fromList toComparable + , Map.toList compare types |> List.map (\( name, ( c, ( preListing, listing ) ) ) -> ( c, Union ( preListing, name ) listing )) |> EverySet.fromList toComparable + ] + + detailedListingIsMultiline : Listing a -> Bool + detailedListingIsMultiline listing = + case listing of + ExplicitListing _ isMultiline -> + isMultiline + + _ -> + False + + varsToExpose : EverySet String (Src.C2 Value) + varsToExpose = + case Maybe.andThen (\(Header _ _ _ exports) -> exports) maybeHeader of + Nothing -> + let + definedVars : EverySet String (Src.C2 Value) + definedVars = + modu.body + |> List.concatMap extractVarName + |> List.map (Tuple.pair ( [], [] )) + |> EverySet.fromList + (\( _, value ) -> + case value of + Value name -> + name + + OpValue name -> + name + + Union ( _, name ) _ -> + name + ) + in + if List.all List.isEmpty documentedVars then + definedVars + + else + let + documentedVarsSet : EverySet String String + documentedVarsSet = + EverySet.fromList identity (List.concat documentedVars) + in + definedVars |> EverySet.filter (\v -> EverySet.member identity (varName v) documentedVarsSet) + + Just ( _, e ) -> + detailedListingToSet e + + sortedExports : ( List (List (Src.C2 Value)), Src.FComments ) + sortedExports = + sortVars + (detailedListingIsMultiline exportsList) + varsToExpose + documentedVars + + extractVarName : TopLevelStructure Declaration -> List Value + extractVarName decl = + case decl of + DocComment _ -> + [] + + BodyComment _ -> + [] + + Entry (PortAnnotation ( _, name ) _ _) -> + [ Value name ] + + Entry (CommonDeclaration def) -> + case def of + Definition (A.At _ pat) _ _ _ -> + case pat of + Src.PVar name -> + [ Value name ] + + Src.PRecord ( _, fields ) -> + List.map (\( _, A.At _ field ) -> Value field) fields + + _ -> + [] + + _ -> + [] + + Entry (Datatype ( _, NameWithArgs name _ ) _) -> + [ Union ( [], name ) (OpenListing ( ( [], [] ), () )) ] + + Entry (TypeAlias _ ( _, NameWithArgs name _ ) _) -> + [ Union ( [], name ) ClosedListing ] + + Entry _ -> + [] + + formatModuleLine_ : Header -> Box + formatModuleLine_ (Header srcTag name moduleSettings exports) = + let + ( preExposing, postExposing ) = + case exports of + Nothing -> + ( [], [] ) + + Just ( ( pre, post ), _ ) -> + ( pre, post ) + in + formatModuleLine sortedExports srcTag name moduleSettings preExposing postExposing + + docs : Maybe Box + docs = + Maybe.map (formatDocComment modu.importInfo) <| A.toValue <| modu.docs + + imports : List Box + imports = + formatImports modu + in + List.concat + (List.intersperse [ Box.blankLine ] <| + List.concat + [ Maybe.toList (Maybe.map (List.singleton << formatModuleLine_) maybeHeader) + , Maybe.toList (Maybe.map List.singleton docs) + , if List.isEmpty imports then + [] + + else + [ imports ] + ] + ) + + +formatImports : Module -> List Box +formatImports modu = + let + ( comments, imports ) = + modu.imports + in + [ formatComments comments + |> Maybe.toList + , imports + |> Map.toList compare + |> List.map (\( name, ( pre, method ) ) -> formatImport ( ( pre, name ), method )) + ] + |> List.filter (not << List.isEmpty) + |> List.intersperse [ Box.blankLine ] + |> List.concat + + +formatModuleLine : + ( List (List (Src.C2 Value)), Src.FComments ) + -> SourceTag + -> Src.C2 (List Name) + -> Maybe (Src.C2 SourceSettings) + -> Src.FComments + -> Src.FComments + -> Box +formatModuleLine ( varsToExpose, extraComments ) srcTag name moduleSettings preExposing postExposing = + let + tag : Box + tag = + case srcTag of + Normal -> + Box.line (Box.keyword "module") + + Port comments -> + ElmStructure.spaceSepOrIndented + (formatTailCommented ( comments, Box.line <| Box.keyword "port" )) + [ Box.line (Box.keyword "module") ] + + Effect comments -> + ElmStructure.spaceSepOrIndented + (formatTailCommented ( comments, Box.line <| Box.keyword "effect" )) + [ Box.line (Box.keyword "module") ] + + exports : Box + exports = + case varsToExpose of + [] -> + Box.line <| Box.keyword "(..)" + + [ oneGroup ] -> + oneGroup + |> List.map (formatCommented << Src.c2map formatVarValue) + |> ElmStructure.group_ False "(" "," (Maybe.toList (formatComments extraComments)) ")" False + + _ -> + varsToExpose + |> List.map (formatCommented << Src.c2map (ElmStructure.group False "" "," "" False << List.map formatVarValue) << Src.sequenceAC2) + |> ElmStructure.group_ False "(" "," (Maybe.toList (formatComments extraComments)) ")" True + + formatSetting : ( Src.C2 String, Src.C2 String ) -> Box + formatSetting ( k, v ) = + formatRecordPair "=" (Box.line << formatUppercaseIdentifier) ( k, v, False ) + + formatSettings : List ( Src.C2 String, Src.C2 String ) -> Box + formatSettings settings = + List.map formatSetting settings + |> ElmStructure.group True "{" "," "}" False + + whereClause : List Box + whereClause = + moduleSettings + |> Maybe.map (formatKeywordCommented "where" << Src.c2map formatSettings) + |> Maybe.map (\x -> [ x ]) + |> Maybe.withDefault [] + + nameClause : Box + nameClause = + case + ( tag + , formatCommented <| Src.c2map (Box.line << formatQualifiedUppercaseIdentifier) name + ) + of + ( Box.SingleLine tag_, Box.SingleLine name_ ) -> + Box.line + (Box.row + [ tag_ + , Box.space + , name_ + ] + ) + + ( tag_, name_ ) -> + Box.stack1 + [ tag_ + , Box.indent name_ + ] + in + ElmStructure.spaceSepOrIndented + (ElmStructure.spaceSepOrIndented + nameClause + (whereClause ++ [ formatCommented ( ( preExposing, postExposing ), Box.line <| Box.keyword "exposing" ) ]) + ) + [ exports ] + + +formatModule : Bool -> Int -> M.Module -> Box +formatModule addDefaultHeader spacing modu = + formatModule_ addDefaultHeader spacing (formatModu modu) + + +formatModu : M.Module -> Module +formatModu modu = + let + declarations : List (TopLevelStructure Declaration) + declarations = + List.concatMap declToDeclarations modu.decls + + ( moduleHeaderComments, imports ) = + List.foldl + (\( comments, Src.Import ( importNameComments, A.At _ importName ) maybeAlias exposing_ ) ( importCommentsAcc, ( importComments, importsAcc ) ) -> + let + exposedVars : Src.C2 (Listing DetailedListing) + exposedVars = + Src.c2map + (\exposing__ -> + case exposing__ of + Src.Open preComments postComments -> + OpenListing ( ( preComments, postComments ), () ) + + Src.Explicit (A.At _ []) -> + ClosedListing + + Src.Explicit (A.At region exposed) -> + ExplicitListing + (List.foldl + (\( entryComments, entry ) acc -> + case entry of + Src.Lower (A.At _ name) -> + { acc | values = Map.insert identity name ( entryComments, () ) acc.values } + + Src.Upper (A.At _ name) ( privacyComments, Src.Public _ ) -> + { acc | types = Map.insert identity name ( entryComments, ( privacyComments, OpenListing ( ( [], [] ), () ) ) ) acc.types } + + Src.Upper (A.At _ name) ( privacyComments, Src.Private ) -> + { acc | types = Map.insert identity name ( entryComments, ( privacyComments, ClosedListing ) ) acc.types } + + Src.Operator _ name -> + { acc | operators = Map.insert identity name ( entryComments, () ) acc.operators } + ) + { values = Map.empty + , operators = Map.empty + , types = Map.empty + } + exposed + ) + (A.isMultiline region) + ) + exposing_ + in + ( comments + , ( importComments ++ importCommentsAcc + , Map.insert identity (String.split "." importName) ( importNameComments, ImportMethod maybeAlias exposedVars ) importsAcc + ) + ) + ) + ( [], Src.c1map (\_ -> Map.empty) modu.imports ) + (Src.c1Value modu.imports) + + body : List (TopLevelStructure Declaration) + body = + List.map BodyComment moduleHeaderComments + ++ List.concatMap + (\( commments, A.At _ (Src.Infix op associativity precedence name) ) -> + Entry (Fixity associativity precedence op name) :: List.map BodyComment commments + ) + (List.reverse modu.infixes) + ++ declarations + in + { importInfo = ImportInfo.fromModule KnownContents.mempty modu + , initialComments = modu.initialComments + , header = + Maybe.map + (\header -> + let + ( sourceTag, sourceSettings ) = + case header.effects of + M.NoEffects _ -> + ( Normal, Nothing ) + + M.Ports _ comments -> + ( Port comments, Nothing ) + + M.Manager _ comments ( postWhereComments, manager ) -> + ( Effect comments + , Just + ( ( [], postWhereComments ) + , case manager of + Src.Cmd ( ( preCmdComments, postCmdComments ), ( ( preEqualComments, postEqualComments ), A.At _ cmdType ) ) -> + [ ( ( ( preCmdComments, preEqualComments ), "command" ), ( ( postEqualComments, postCmdComments ), cmdType ) ) + ] + + Src.Sub ( ( preSubComments, postSubComments ), ( ( preEqualComments, postEqualComments ), A.At _ subType ) ) -> + [ ( ( ( preSubComments, preEqualComments ), "subscription" ), ( ( postEqualComments, postSubComments ), subType ) ) + ] + + Src.Fx ( ( preCmdComments, postCmdComments ), ( ( preEqualCmdComments, postEqualCmdComments ), A.At (A.Region (A.Position cmdTypeStart cmdTypeEnd) _) cmdType ) ) ( ( preSubComments, postSubComments ), ( ( preEqualSubComments, postEqualSubComments ), A.At (A.Region (A.Position subTypeStart subTypeEnd) _) subType ) ) -> + [ ( ( cmdTypeStart, cmdTypeEnd ), ( ( ( preCmdComments, preEqualCmdComments ), "command" ), ( ( postEqualCmdComments, postCmdComments ), cmdType ) ) ) + , ( ( subTypeStart, subTypeEnd ), ( ( ( preSubComments, preEqualSubComments ), "subscription" ), ( ( postEqualSubComments, postSubComments ), subType ) ) ) + ] + |> List.sortBy Tuple.first + |> List.map Tuple.second + ) + ) + + exportsListing : Src.C2 (Listing DetailedListing) + exportsListing = + Src.c2map + (\(A.At _ exposing_) -> + case exposing_ of + Src.Open preComments postComments -> + OpenListing ( ( preComments, postComments ), () ) + + Src.Explicit (A.At region exposed) -> + ExplicitListing + (List.foldl + (\( entryComments, entry ) acc -> + case entry of + Src.Lower (A.At _ name) -> + { acc | values = Map.insert identity name ( entryComments, () ) acc.values } + + Src.Upper (A.At _ name) ( privacyComments, Src.Public _ ) -> + { acc | types = Map.insert identity name ( entryComments, ( privacyComments, OpenListing ( ( [], [] ), () ) ) ) acc.types } + + Src.Upper (A.At _ name) ( privacyComments, Src.Private ) -> + { acc | types = Map.insert identity name ( entryComments, ( privacyComments, ClosedListing ) ) acc.types } + + Src.Operator _ name -> + { acc | operators = Map.insert identity name ( entryComments, () ) acc.operators } + ) + { values = Map.empty + , operators = Map.empty + , types = Map.empty + } + exposed + ) + (A.isMultiline region) + ) + header.exports + in + Header sourceTag (Src.c2map (String.split "." << A.toValue) header.name) sourceSettings (Just exportsListing) + ) + modu.header + , docs = + modu.header + |> Maybe.andThen (.docs >> Result.toMaybe) + |> Maybe.map + (\(Src.Comment (P.Snippet { fptr, offset, length })) -> + String.slice offset (offset + length) fptr + |> String.trim + |> Parse.markdown + (Options + { sanitize = True + , allowRawHtml = True + , preserveHardBreaks = True + , debug = False + } + ) + |> (\(Doc _ blocks) -> blocks) + ) + |> A.At A.zero + , imports = imports + , body = body + } + + +declToDeclarations : Src.C2 Decl.Decl -> List (TopLevelStructure Declaration) +declToDeclarations ( ( preDeclComments, postDeclComments ), decl ) = + List.map BodyComment preDeclComments + ++ (case decl of + Decl.Value maybeDocs (A.At _ (Src.Value preValueComments ( postNameComments, A.At nameRegion name ) srcArgs ( valueBodyComments, valueBody ) maybeType)) -> + (maybeDocs + |> Maybe.map + (\(Src.Comment (P.Snippet { fptr, offset, length })) -> + [ DocComment + (String.slice offset (offset + length) fptr + |> String.trim + |> Parse.markdown + (Options + { sanitize = True + , allowRawHtml = True + , preserveHardBreaks = True + , debug = False + } + ) + |> (\(Doc _ blocks) -> blocks) + ) + ] + ) + |> Maybe.withDefault [] + ) + ++ List.map BodyComment preValueComments + ++ (maybeType + |> Maybe.map + (\( postComments, ( ( preTypComments, postTypeComments ), typ ) ) -> + Entry (CommonDeclaration (TypeAnnotation ( preTypComments, VarRef () name ) ( postTypeComments, typ ))) + :: List.map BodyComment postComments + ) + |> Maybe.withDefault [] + ) + ++ [ Entry (CommonDeclaration (Definition (A.At nameRegion (Src.PVar name)) srcArgs (postNameComments ++ valueBodyComments) valueBody)) ] + + Decl.Union maybeDocs (A.At _ (Src.Union ( nameComments, A.At _ name ) args constructors)) -> + let + ( postTagsComments, tags ) = + case List.reverse constructors of + ( ( preLastConstructorComments, postLastConstructorComments, _ ), ( A.At _ lastName, lastArgs ) ) :: restConstructors -> + ( postLastConstructorComments + , Src.OpenCommentedList + (List.map + (\( comments, ( A.At _ constructorName, constructorArgs ) ) -> + ( comments, NameWithArgs constructorName constructorArgs ) + ) + (List.reverse restConstructors) + ) + ( preLastConstructorComments, Nothing, NameWithArgs lastName lastArgs ) + ) + + -- Note: the following case should not occur, since + -- it is invalid to have a union type without constructors. + _ -> + crash "union type without constructors" + in + (maybeDocs + |> Maybe.map + (\(Src.Comment (P.Snippet { fptr, offset, length })) -> + [ DocComment + (String.slice offset (offset + length) fptr + |> String.trim + |> Parse.markdown + (Options + { sanitize = True + , allowRawHtml = True + , preserveHardBreaks = True + , debug = False + } + ) + |> (\(Doc _ blocks) -> blocks) + ) + ] + ) + |> Maybe.withDefault [] + ) + ++ Entry (Datatype ( nameComments, NameWithArgs name (List.map (Src.c1map A.toValue) args) ) tags) + :: List.map BodyComment postTagsComments + + Decl.Alias maybeDocs (A.At _ (Src.Alias comments name args tipe)) -> + let + nameWithArgs : Src.C2 (NameWithArgs Name Name) + nameWithArgs = + Src.c2map + (\(A.At _ n) -> + NameWithArgs n (List.map (Src.c1map A.toValue) args) + ) + name + in + (maybeDocs + |> Maybe.map + (\(Src.Comment (P.Snippet { fptr, offset, length })) -> + [ DocComment + (String.slice offset (offset + length) fptr + |> String.trim + |> Parse.markdown + (Options + { sanitize = True + , allowRawHtml = True + , preserveHardBreaks = True + , debug = False + } + ) + |> (\(Doc _ blocks) -> blocks) + ) + ] + ) + |> Maybe.withDefault [] + ) + ++ [ Entry (TypeAlias comments nameWithArgs tipe) ] + + Decl.Port maybeDocs (Src.Port comments name tipe) -> + (maybeDocs + |> Maybe.map + (\(Src.Comment (P.Snippet { fptr, offset, length })) -> + [ DocComment + (String.slice offset (offset + length) fptr + |> String.trim + |> Parse.markdown + (Options + { sanitize = True + , allowRawHtml = True + , preserveHardBreaks = True + , debug = False + } + ) + |> (\(Doc _ blocks) -> blocks) + ) + ] + ) + |> Maybe.withDefault [] + ) + ++ [ Entry (PortAnnotation (Src.c2map A.toValue name) comments tipe) ] + ) + ++ List.map BodyComment postDeclComments + + +formatModule_ : Bool -> Int -> Module -> Box +formatModule_ addDefaultHeader spacing modu = + let + initialComments_ : List Box + initialComments_ = + case modu.initialComments of + [] -> + [] + + comments -> + List.map formatComment comments + ++ [ Box.blankLine, Box.blankLine ] + + spaceBeforeBody : Int + spaceBeforeBody = + case modu.body of + [] -> + 0 + + (BodyComment _) :: _ -> + spacing + 1 + + _ -> + spacing + + decls : List (TopLevelStructure Declaration) + decls = + modu.body + in + Box.stack1 <| + List.concat + [ initialComments_ + , formatModuleHeader addDefaultHeader modu + , List.repeat spaceBeforeBody Box.blankLine + , Maybe.toList <| formatModuleBody spacing modu.importInfo decls + ] + + +formatModuleBody : Int -> ImportInfo -> List (TopLevelStructure Declaration) -> Maybe Box +formatModuleBody linesBetween importInfo body = + let + entryType : Declaration -> BodyEntryType + entryType adecl = + case adecl of + CommonDeclaration def -> + case def of + Definition (A.At _ pat) _ _ _ -> + case pat of + Src.PVar name -> + BodyNamed <| VarRef () name + + _ -> + BodyUnnamed + + TypeAnnotation ( _, name ) _ -> + BodyNamed name + + Datatype ( _, NameWithArgs name _ ) _ -> + BodyNamed <| TagRef () name + + TypeAlias _ ( _, NameWithArgs name _ ) _ -> + BodyNamed <| TagRef () name + + PortAnnotation ( _, name ) _ _ -> + BodyNamed <| VarRef () name + + Fixity _ _ _ _ -> + BodyFixity + in + formatTopLevelBody linesBetween importInfo <| + List.map (topLevelStructureMap (\b -> ( entryType b, formatDeclaration importInfo b ))) body + + +type BodyEntryType + = BodyNamed (Ref ()) + | BodyUnnamed + | BodyFixity + + +formatTopLevelBody : + Int + -> ImportInfo + -> List (TopLevelStructure ( BodyEntryType, Box )) + -> Maybe Box +formatTopLevelBody linesBetween importInfo body = + let + extraLines : Int -> List Box + extraLines n = + List.repeat n Box.blankLine + + spacer : TopLevelStructure ( BodyEntryType, Box ) -> TopLevelStructure ( BodyEntryType, Box ) -> Int + spacer a b = + case ( declarationType (topLevelStructureMap Tuple.first a), declarationType (topLevelStructureMap Tuple.first b) ) of + ( DStarter, _ ) -> + 0 + + ( _, DCloser ) -> + 0 + + ( DComment, DComment ) -> + 0 + + ( _, DComment ) -> + if linesBetween == 1 then + 1 + + else + linesBetween + 1 + + ( DComment, DDefinition _ ) -> + if linesBetween == 1 then + 0 + + else + linesBetween + + ( DComment, _ ) -> + linesBetween + + ( DDocComment, DDefinition _ ) -> + 0 + + ( DDefinition Nothing, DDefinition (Just _) ) -> + linesBetween + + ( DDefinition _, DStarter ) -> + linesBetween + + ( DDefinition Nothing, DDefinition Nothing ) -> + linesBetween + + ( DDefinition a_, DDefinition b_ ) -> + if a_ == b_ then + 0 + + else + linesBetween + + ( DCloser, _ ) -> + linesBetween + + ( _, DDocComment ) -> + linesBetween + + ( DDocComment, DStarter ) -> + 0 + + ( DFixity, DFixity ) -> + 0 + + ( DFixity, _ ) -> + linesBetween + + ( _, DFixity ) -> + linesBetween + + boxes : List Box + boxes = + intersperseMap (\a b -> extraLines <| spacer a b) + (formatTopLevelStructure importInfo << topLevelStructureMap Tuple.second) + body + in + case boxes of + [] -> + Nothing + + _ -> + Just <| Box.stack1 boxes + + +type ElmCodeBlock + = DeclarationsCode (List (TopLevelStructure Declaration)) + | ExpressionsCode (List (TopLevelStructure (Src.C0Eol Src.Expr))) + | ModuleCode Module + + +formatDocComment : ImportInfo -> Blocks -> Box +formatDocComment importInfo blocks = + let + parse : String -> Maybe ElmCodeBlock + parse source = + source + |> Maybe.oneOf + [ Maybe.map DeclarationsCode << Result.toMaybe << parseDeclarations + , Maybe.map ExpressionsCode << Result.toMaybe << parseExpressions + , Maybe.map ModuleCode << Result.toMaybe << parseModule + ] + + format : ElmCodeBlock -> String + format result = + case result of + ModuleCode modu -> + formatModule_ False 1 modu + |> Box.render + + DeclarationsCode declarations -> + formatModuleBody 1 importInfo declarations + |> Maybe.map Box.render + |> Maybe.withDefault "" + + ExpressionsCode expressions -> + expressions + |> List.map (topLevelStructureMap (formatEolCommented << Src.c0EolMap (syntaxParens SyntaxSeparated << formatExpression importInfo))) + |> List.map (topLevelStructureMap (Tuple.pair BodyUnnamed)) + |> formatTopLevelBody 1 importInfo + |> Maybe.map Box.render + |> Maybe.withDefault "" + + content : String + content = + Markdown.formatMarkdown (Maybe.map format << parse) (List.map cleanBlock blocks) + + cleanBlock : Block -> Block + cleanBlock block = + case block of + ElmDocs docs -> + ElmDocs <| + (List.map << List.map) + (String.replace "(..)" "") + docs + + _ -> + block + in + formatDocCommentString content + + +parseDeclarations : String -> Result () (List (TopLevelStructure Declaration)) +parseDeclarations source = + -- TODO/FIXME SyntaxVersion + P.fromByteString (P.specialize (\_ -> Tuple.pair) (Decl.declaration SV.Guida)) Tuple.pair source + |> Result.mapError (\_ -> ()) + |> Result.map (\( decl, _ ) -> declToDeclarations decl) + + +parseExpressions : String -> Result () (List (TopLevelStructure (Src.C0Eol Src.Expr))) +parseExpressions source = + -- TODO/FIXME SyntaxVersion + P.fromByteString (P.specialize (\_ -> Tuple.pair) (Expr.expression SV.Guida)) Tuple.pair source + |> Result.mapError (\_ -> ()) + |> Result.map (\( ( _, expr ), _ ) -> [ Entry ( Nothing, expr ) ]) + + +parseModule : String -> Result () Module +parseModule source = + -- TODO/FIXME SyntaxVersion + P.fromByteString (P.specialize (\_ -> Tuple.pair) (M.chompModule SV.Guida M.Application)) Tuple.pair source + |> Result.mapError (\_ -> ()) + |> Result.map formatModu + + +formatDocCommentString : String -> Box +formatDocCommentString docs = + case lines docs of + [] -> + Box.line <| Box.row [ Box.punc "{-|", Box.space, Box.punc "-}" ] + + [ first ] -> + Box.stack1 + [ Box.line <| Box.row [ Box.punc "{-|", Box.space, Box.literal first ] + , Box.line <| Box.punc "-}" + ] + + first :: rest -> + Box.line (Box.row [ Box.punc "{-|", Box.space, Box.literal first ]) + |> Box.andThen (List.map (Box.line << Box.literal) rest) + |> Box.andThen [ Box.line <| Box.punc "-}" ] + + +lines : String -> List String +lines str = + case List.reverse (String.lines str) of + "" :: rest -> + List.reverse rest + + result -> + List.reverse result + + +formatImport : UserImport -> Box +formatImport ( ( _, rawName ) as name, (ImportMethod _ exposedVars) as method ) = + let + requestedAs : Maybe (Src.C2 Name) + requestedAs = + case method of + ImportMethod ((Just ( _, aliasName )) as other) _ -> + if [ aliasName ] == rawName then + Nothing + + else + other + + ImportMethod other _ -> + other + + asVar : Maybe Box + asVar = + requestedAs + |> Maybe.map + (formatImportClause + (Just << Box.line << formatUppercaseIdentifier) + "as" + ) + |> Maybe.join + + exposingVar : Maybe Box + exposingVar = + formatImportClause + (formatListing formatDetailedListing) + "exposing" + exposedVars + + formatImportClause : (a -> Maybe Box) -> String -> Src.C2 a -> Maybe Box + formatImportClause format keyw input = + case Src.c2map format input of + ( ( [], [] ), Nothing ) -> + Nothing + + ( ( preKeyword, postKeyword ), Just listing_ ) -> + case + ( formatPreCommented ( preKeyword, Box.line (Box.keyword keyw) ) + , formatPreCommented ( postKeyword, listing_ ) + ) + of + ( Box.SingleLine keyword_, Box.SingleLine listing__ ) -> + Just + (Box.line + (Box.row + [ keyword_ + , Box.space + , listing__ + ] + ) + ) + + ( keyword_, listing__ ) -> + Just + (Box.stack1 + [ keyword_ + , Box.indent listing__ + ] + ) + + _ -> + Just (pleaseReport "UNEXPECTED IMPORT" "import clause comments with no clause") + in + case + ( formatPreCommented <| Src.c1map (Box.line << formatQualifiedUppercaseIdentifier) name + , asVar + , exposingVar + ) + of + ( Box.SingleLine name_, Just (Box.SingleLine as_), Just (Box.SingleLine exposing__) ) -> + Box.line <| + Box.row + [ Box.keyword "import" + , Box.space + , name_ + , Box.space + , as_ + , Box.space + , exposing__ + ] + + ( Box.SingleLine name_, Just (Box.SingleLine as_), Nothing ) -> + Box.line <| + Box.row + [ Box.keyword "import" + , Box.space + , name_ + , Box.space + , as_ + ] + + ( Box.SingleLine name_, Nothing, Just (Box.SingleLine exposing__) ) -> + Box.line <| + Box.row + [ Box.keyword "import" + , Box.space + , name_ + , Box.space + , exposing__ + ] + + ( Box.SingleLine name_, Nothing, Nothing ) -> + Box.line <| + Box.row + [ Box.keyword "import" + , Box.space + , name_ + ] + + ( Box.SingleLine name_, Just (Box.SingleLine as_), Just exposing__ ) -> + Box.stack1 + [ Box.line <| + Box.row + [ Box.keyword "import" + , Box.space + , name_ + , Box.space + , as_ + ] + , Box.indent exposing__ + ] + + ( Box.SingleLine name_, Just as_, Just exposing__ ) -> + Box.stack1 + [ Box.line <| + Box.row + [ Box.keyword "import" + , Box.space + , name_ + ] + , Box.indent as_ + , Box.indent exposing__ + ] + + ( Box.SingleLine name_, Nothing, Just exposing__ ) -> + Box.stack1 + [ Box.line <| + Box.row + [ Box.keyword "import" + , Box.space + , name_ + ] + , Box.indent exposing__ + ] + + ( name_, Just as_, Just exposing__ ) -> + Box.stack1 + [ Box.line <| Box.keyword "import" + , Box.indent name_ + , Box.indent <| Box.indent as_ + , Box.indent <| Box.indent exposing__ + ] + + ( name_, Nothing, Just exposing__ ) -> + Box.stack1 + [ Box.line <| Box.keyword "import" + , Box.indent name_ + , Box.indent <| Box.indent exposing__ + ] + + ( name_, Just as_, Nothing ) -> + Box.stack1 + [ Box.line <| Box.keyword "import" + , Box.indent name_ + , Box.indent <| Box.indent as_ + ] + + ( name_, Nothing, Nothing ) -> + Box.stack1 + [ Box.line <| Box.keyword "import" + , Box.indent name_ + ] + + +formatListing : (a -> List Box) -> Listing a -> Maybe Box +formatListing format listing = + case listing of + ClosedListing -> + Nothing + + OpenListing ( comments, () ) -> + Just <| parens <| formatCommented <| ( comments, Box.line <| Box.keyword ".." ) + + ExplicitListing vars multiline -> + case format vars of + [] -> + Nothing + + vars_ -> + Just <| ElmStructure.group False "(" "," ")" multiline vars_ + + + +-- formatExposing : (List (Src.C2 Src.Exposed) -> List Box) -> Src.Exposing -> Maybe Box +-- formatExposing format listing = +-- case listing of +-- Src.Open preComments postComments -> +-- Just (parens (formatCommented ( preComments, postComments, Box.line (Box.keyword "..") ))) +-- Src.Explicit (A.At _ []) -> +-- Nothing +-- Src.Explicit (A.At region exposedList) -> +-- case format exposedList of +-- [] -> +-- Nothing +-- vars_ -> +-- let +-- multiline = +-- A.isMultiline region +-- in +-- Just <| ElmStructure.group False "(" "," ")" multiline vars_ + + +formatDetailedListing : DetailedListing -> List Box +formatDetailedListing listing = + List.concat + [ formatCommentedMap compare + (\name () -> OpValue name) + formatVarValue + listing.operators + , formatCommentedMap compare + (\name ( inner, listing_ ) -> Union ( inner, name ) listing_) + formatVarValue + listing.types + , formatCommentedMap compare + (\name () -> Value name) + formatVarValue + listing.values + ] + + +formatCommentedMap : (k -> k -> Order) -> (k -> v -> a) -> (a -> Box) -> CommentedMap k v -> List Box +formatCommentedMap keyComparison construct format values = + let + format_ : ( k, Src.C2 v ) -> Box + format_ ( k, ( c, v ) ) = + formatCommented ( c, format (construct k v) ) + in + values + |> Map.toList keyComparison + |> List.map format_ + + +formatVarValue : Value -> Box +formatVarValue aval = + case aval of + Value val -> + Box.line <| formatLowercaseIdentifier [] val + + OpValue name -> + Box.line <| Box.identifier <| "(" ++ name ++ ")" + + Union name listing -> + case + ( formatListing + (formatCommentedMap compare + (\name_ () -> name_) + (Box.line << formatUppercaseIdentifier) + ) + listing + , formatTailCommented <| Src.c1map (Box.line << formatUppercaseIdentifier) name + , (\( c, _ ) -> c) name + ) + of + ( Just _, _, _ ) -> + formatTailCommented <| + Src.c1map (\n -> Box.line <| Box.row [ formatUppercaseIdentifier n, Box.keyword "(..)" ]) + name + + ( Nothing, name_, _ ) -> + name_ + + +formatTopLevelStructure : ImportInfo -> TopLevelStructure Box -> Box +formatTopLevelStructure importInfo topLevelStructure = + case topLevelStructure of + DocComment docs -> + formatDocComment importInfo docs + + BodyComment c -> + formatComment c + + Entry entry -> + entry + + +formatCommonDeclaration : ImportInfo -> CommonDeclaration -> Box +formatCommonDeclaration importInfo decl = + case decl of + Definition name args comments expr -> + formatDefinition importInfo name args comments expr + + TypeAnnotation name typ -> + formatTypeAnnotation name typ + + +formatDeclaration : ImportInfo -> Declaration -> Box +formatDeclaration importInfo decl = + case decl of + CommonDeclaration def -> + formatCommonDeclaration importInfo def + + Datatype nameWithArgs tags -> + let + ctor : NameWithArgs Name Src.Type -> Box + ctor (NameWithArgs tag args_) = + case Box.allSingles <| List.map (formatPreCommented << Src.c1map (typeParens ForCtor << formatType)) args_ of + Ok args__ -> + Box.line <| Box.row <| List.intersperse Box.space <| formatUppercaseIdentifier tag :: args__ + + Err [] -> + Box.line <| formatUppercaseIdentifier tag + + Err args__ -> + Box.stack1 + [ Box.line <| formatUppercaseIdentifier tag + , Box.stack1 args__ + |> Box.indent + ] + in + case + formatOpenCommentedList <| Src.openCommentedListMap ctor tags + of + [] -> + crash "List can't be empty" + + first :: rest -> + case formatCommented <| Src.c2map formatNameWithArgs nameWithArgs of + Box.SingleLine nameWithArgs_ -> + Box.stack1 + [ Box.line <| + Box.row + [ Box.keyword "type" + , Box.space + , nameWithArgs_ + ] + , first + |> Box.prefix (Box.row [ Box.punc "=", Box.space ]) + |> Box.andThen (List.map (Box.prefix (Box.row [ Box.punc "|", Box.space ])) rest) + |> Box.indent + ] + + nameWithArgs_ -> + Box.stack1 + [ Box.line <| Box.keyword "type" + , Box.indent nameWithArgs_ + , first + |> Box.prefix (Box.row [ Box.punc "=", Box.space ]) + |> Box.andThen (List.map (Box.prefix (Box.row [ Box.punc "|", Box.space ])) rest) + |> Box.indent + ] + + TypeAlias preAlias nameWithArgs typ -> + ElmStructure.definition "=" + True + (Box.line <| Box.keyword "type") + [ formatPreCommented ( preAlias, Box.line <| Box.keyword "alias" ) + , formatCommented <| Src.c2map formatNameWithArgs nameWithArgs + ] + (formatPreCommentedStack <| Src.c1map (typeParens NotRequired << formatType) typ) + + PortAnnotation name typeComments typ -> + ElmStructure.definition ":" + False + (Box.line <| Box.keyword "port") + [ formatCommented <| Src.c2map (Box.line << formatLowercaseIdentifier []) name ] + (formatCommentedApostrophe typeComments <| typeParens NotRequired <| formatType typ) + + Fixity assoc precedence name value -> + let + formatAssoc : Binop.Associativity -> Box.Line + formatAssoc a = + case a of + Binop.Left -> + Box.keyword "left " + + Binop.Right -> + Box.keyword "right" + + Binop.Non -> + Box.keyword "non " + in + ElmStructure.spaceSepOrIndented + (Box.line <| Box.keyword "infix") + [ formatPreCommented <| Src.c1map (Box.line << formatAssoc) assoc + , formatPreCommented <| Src.c1map (Box.line << Box.literal << String.fromInt) precedence + , formatCommented <| Src.c2map (Box.line << formatSymbolIdentifierInParens) name + , Box.line <| Box.keyword "=" + , formatPreCommented <| Src.c1map (Box.line << Box.identifier << formatVarName) value + ] + + +formatNameWithArgs : NameWithArgs Name Name -> Box +formatNameWithArgs (NameWithArgs name args) = + case Box.allSingles <| List.map (formatPreCommented << Src.c1map (Box.line << formatLowercaseIdentifier [])) args of + Ok args_ -> + Box.line <| Box.row <| List.intersperse Box.space (formatUppercaseIdentifier name :: args_) + + Err args_ -> + Box.stack1 <| + (Box.line <| formatUppercaseIdentifier name) + :: List.map Box.indent args_ + + +formatDefinition : ImportInfo -> Src.Pattern -> List (Src.C1 Src.Pattern) -> Src.FComments -> Src.Expr -> Box +formatDefinition importInfo (A.At _ name) args comments expr = + let + body : Box + body = + Box.stack1 + (List.concat + [ List.map formatComment comments + , [ syntaxParens SyntaxSeparated (formatExpression importInfo expr) ] + ] + ) + in + ElmStructure.definition "=" + True + (syntaxParens SpaceSeparated (formatPattern name)) + (List.map (\( x, A.At _ y ) -> formatCommentedApostrophe x (syntaxParens SpaceSeparated (formatPattern y))) args) + body + + +formatTypeAnnotation : Src.C1 (Ref ()) -> Src.C1 Src.Type -> Box +formatTypeAnnotation name typ = + ElmStructure.definition ":" + False + (formatTailCommented (Src.c1map (Box.line << formatVar << refMap (\() -> [])) name)) + [] + (formatPreCommented (Src.c1map (typeParens NotRequired << formatType) typ)) + + +formatPattern : Src.Pattern_ -> ( SyntaxContext, Box ) +formatPattern apattern = + case apattern of + Src.PAnything name -> + ( SyntaxSeparated, Box.line (Box.identifier ("_" ++ name)) ) + + Src.PVar name -> + ( SyntaxSeparated, Box.line (formatLowercaseIdentifier [] name) ) + + Src.PRecord ( comments, [] ) -> + ( SyntaxSeparated + , formatUnit '{' '}' comments + ) + + Src.PRecord ( _, fields ) -> + ( SyntaxSeparated + , ElmStructure.group True "{" "," "}" False (List.map (formatCommented << Src.c2map (Box.line << formatLowercaseIdentifier [] << A.toValue)) (List.reverse fields)) + ) + + Src.PAlias aliasPattern name -> + ( SpaceSeparated + , case + ( formatTailCommented (Src.c1map (syntaxParens SpaceSeparated << formatPattern << A.toValue) aliasPattern) + , formatPreCommented (Src.c1map (Box.line << formatLowercaseIdentifier [] << A.toValue) name) + ) + of + ( Box.SingleLine pattern_, Box.SingleLine name_ ) -> + Box.line + (Box.row + [ pattern_ + , Box.space + , Box.keyword "as" + , Box.space + , name_ + ] + ) + + ( pattern_, name_ ) -> + Box.stack1 + [ pattern_ + , Box.line (Box.keyword "as") + , Box.indent name_ + ] + ) + + Src.PUnit comments -> + ( SyntaxSeparated, formatUnit '(' ')' comments ) + + Src.PTuple a b cs -> + let + patterns : List (Src.C2 Src.Pattern) + patterns = + a :: b :: cs + in + ( SyntaxSeparated + , ElmStructure.group True "(" "," ")" False (List.map (formatCommented << Src.c2map (syntaxParens SyntaxSeparated << formatPattern << A.toValue)) patterns) + ) + + Src.PCtor _ name [] -> + let + ctor : List Name + ctor = + [ name ] + in + ( SyntaxSeparated + , Box.line (formatQualifiedUppercaseIdentifier ctor) + ) + + Src.PCtor _ name patterns -> + let + ctor : List Name + ctor = + [ name ] + in + ( SpaceSeparated + , ElmStructure.application + (ElmStructure.FAJoinFirst ElmStructure.JoinAll) + (Box.line (formatQualifiedUppercaseIdentifier ctor)) + (List.map (formatPreCommented << Src.c1map (syntaxParens SpaceSeparated << formatPattern << A.toValue)) patterns) + ) + + Src.PCtorQual _ home name [] -> + let + ctor : List String + ctor = + String.split "." home ++ [ name ] + in + ( SyntaxSeparated + , Box.line (formatQualifiedUppercaseIdentifier ctor) + ) + + Src.PCtorQual _ home name patterns -> + let + ctor : List String + ctor = + String.split "." home ++ [ name ] + in + ( SpaceSeparated + , ElmStructure.application + (ElmStructure.FAJoinFirst ElmStructure.JoinAll) + (Box.line (formatQualifiedUppercaseIdentifier ctor)) + (List.map (formatPreCommented << Src.c1map (syntaxParens SpaceSeparated << formatPattern << A.toValue)) patterns) + ) + + Src.PList ( comments, [] ) -> + ( SyntaxSeparated + , formatUnit '[' ']' comments + ) + + Src.PList ( _, patterns ) -> + ( SyntaxSeparated + , ElmStructure.group True "[" "," "]" False (List.map (formatCommented << Src.c2map (syntaxParens SyntaxSeparated << formatPattern << A.toValue)) patterns) + ) + + Src.PCons hd tl -> + let + go : List (Src.C2Eol Src.Pattern) -> Src.C2Eol Src.Pattern -> List (Src.C2Eol Src.Pattern) + go acc p = + case p of + ( comments, A.At _ (Src.PCons ( _, hd_ ) tl_) ) -> + go (( comments, hd_ ) :: acc) tl_ + + _ -> + List.reverse (p :: acc) + + rest : List (Src.C2Eol Src.Pattern) + rest = + go [] tl + + formatRight : Src.C2Eol Src.Pattern -> ( ( Bool, Src.FComments, Box ), Box ) + formatRight ( ( preOp, postOp, eol ), term ) = + ( ( False + , preOp + , Box.line (Box.punc "::") + ) + , formatC2Eol + (Src.c2EolMap (syntaxParens SpaceSeparated << formatPattern << A.toValue) + ( ( postOp, [], eol ), term ) + ) + ) + in + ( SpaceSeparated + , formatBinary False + (formatEolCommented (Src.c0EolMap (syntaxParens SpaceSeparated << formatPattern << A.toValue) hd)) + (List.map formatRight rest) + ) + + Src.PChr chr -> + ( SyntaxSeparated, formatString SChar chr ) + + Src.PStr str False -> + ( SyntaxSeparated, formatString (SString SingleQuotedString) str ) + + Src.PStr str True -> + ( SyntaxSeparated, formatString (SString TripleQuotedString) str ) + + Src.PInt _ src -> + ( SyntaxSeparated + , formatLiteral (IntNum src) + ) + + Src.PParens ( ( [], [] ), A.At _ pattern ) -> + formatPattern pattern + + Src.PParens pattern -> + ( SyntaxSeparated + , parens (formatCommented (Src.c2map (syntaxParens SyntaxSeparated << formatPattern << A.toValue) pattern)) + ) + + +formatRecordPair : String -> (v -> Box) -> ( Src.C2 String, Src.C2 v, Bool ) -> Box +formatRecordPair delim formatValue ( ( ( pre, postK ), k ), v, forceMultiline ) = + ElmStructure.equalsPair delim + forceMultiline + (formatCommented <| Src.c2map (Box.line << formatLowercaseIdentifier []) ( ( [], postK ), k )) + (formatCommented <| Src.c2map formatValue v) + |> Tuple.pair pre + |> formatPreCommented + + +formatPair : String -> Src.Pair Box.Line Box -> Box +formatPair delim (Src.Pair a b (Src.ForceMultiline forceMultiline)) = + ElmStructure.equalsPair delim + forceMultiline + (formatTailCommented <| Src.c1map Box.line a) + (formatPreCommented b) + + +negativeCasePatternWorkaround : Src.Pattern_ -> Box -> Box +negativeCasePatternWorkaround pattern = + case pattern of + Src.PInt i _ -> + if i < 0 then + parens + + else + identity + + _ -> + identity + + +type SyntaxContext + = SyntaxSeparated + | InfixSeparated + | SpaceSeparated + | AmbiguousEnd + + +syntaxParens : SyntaxContext -> ( SyntaxContext, Box ) -> Box +syntaxParens outer ( inner, box ) = + let + parensIf : Bool -> Box -> Box + parensIf bool = + if bool then + parens + + else + identity + in + parensIf (needsParensInContext inner outer) box + + +needsParensInContext : SyntaxContext -> SyntaxContext -> Bool +needsParensInContext inner outer = + case ( inner, outer ) of + ( SpaceSeparated, SpaceSeparated ) -> + True + + ( InfixSeparated, SpaceSeparated ) -> + True + + ( InfixSeparated, InfixSeparated ) -> + True + + ( AmbiguousEnd, SpaceSeparated ) -> + True + + ( AmbiguousEnd, InfixSeparated ) -> + True + + ( InfixSeparated, AmbiguousEnd ) -> + True + + _ -> + False + + +formatExpression : ImportInfo -> Src.Expr -> ( SyntaxContext, Box ) +formatExpression importInfo (A.At region aexpr) = + case aexpr of + Src.Chr char -> + ( SyntaxSeparated, formatString SChar char ) + + Src.Str string False -> + ( SyntaxSeparated, formatString (SString SingleQuotedString) string ) + + Src.Str string True -> + ( SyntaxSeparated, formatString (SString TripleQuotedString) string ) + + Src.Int _ src -> + ( SyntaxSeparated, formatLiteral (IntNum src) ) + + Src.Float _ src -> + ( SyntaxSeparated, formatLiteral (FloatNum src) ) + + Src.Var Src.LowVar name -> + ( SyntaxSeparated, Box.line (formatVar (VarRef [] name)) ) + + Src.Var Src.CapVar name -> + ( SyntaxSeparated, Box.line (formatVar (TagRef [] name)) ) + + Src.VarQual Src.LowVar prefix name -> + ( SyntaxSeparated, Box.line (formatVar (VarRef (String.split "." prefix) name)) ) + + Src.VarQual Src.CapVar prefix name -> + ( SyntaxSeparated, Box.line (formatVar (TagRef (String.split "." prefix) name)) ) + + Src.List list trailing -> + let + multiline : Src.ForceMultiline + multiline = + Src.ForceMultiline (A.isMultiline region) + in + ( SyntaxSeparated + , formatSequence '[' + ',' + (Just ']') + multiline + trailing + (List.map (Src.c2EolMap (syntaxParens SyntaxSeparated << formatExpression importInfo)) list) + ) + + Src.Op op -> + ( SyntaxSeparated + , Box.line (formatSymbolIdentifierInParens op) + ) + + Src.Negate expr -> + ( SyntaxSeparated + -- TODO: This might need something stronger than SpaceSeparated? + , Box.prefix (Box.punc "-") (syntaxParens SpaceSeparated (formatExpression importInfo expr)) + ) + + Src.Binops ops final -> + let + ( left, clauses ) = + List.foldr + (\( currExpr, ( ( preOpComments, postOpComments ), A.At _ currOp ) ) ( leftAcc, clausesAcc ) -> + ( currExpr, BinopsClause preOpComments (OpRef currOp) postOpComments leftAcc :: clausesAcc ) + ) + ( final, [] ) + ops + + multiline : Bool + multiline = + A.isMultiline region + in + ( InfixSeparated + , formatBinops importInfo left clauses multiline + ) + + Src.Lambda ( trailingComments, srcArgs ) ( exprComments, expr ) -> + let + multiline : Bool + multiline = + A.isMultiline region + + bodyComments : Src.FComments + bodyComments = + trailingComments ++ exprComments + in + ( AmbiguousEnd + , case + ( ( multiline + , Box.allSingles (List.map (formatPreCommented << Src.c1map (syntaxParens SpaceSeparated << formatPattern << A.toValue)) srcArgs) + ) + , ( bodyComments == [] + , syntaxParens SyntaxSeparated (formatExpression importInfo expr) + ) + ) + of + ( ( False, Ok patterns_ ), ( True, Box.SingleLine expr_ ) ) -> + Box.line <| + Box.row + [ Box.punc "\\" + , Box.row <| List.intersperse Box.space patterns_ + , Box.space + , Box.punc "->" + , Box.space + , expr_ + ] + + ( ( _, Ok patterns_ ), ( _, expr_ ) ) -> + Box.stack1 + [ Box.line <| + Box.row + [ Box.punc "\\" + , Box.row (List.intersperse Box.space patterns_) + , Box.space + , Box.punc "->" + ] + , Box.indent <| + Box.stack1 <| + List.map formatComment bodyComments + ++ [ expr_ ] + ] + + ( ( _, Err [] ), _ ) -> + pleaseReport "UNEXPECTED LAMBDA" "no patterns" + + ( ( _, Err patterns_ ), ( _, expr_ ) ) -> + Box.stack1 + [ Box.prefix (Box.punc "\\") <| Box.stack1 patterns_ + , Box.line <| Box.punc "->" + , Box.indent <| + Box.stack1 <| + List.map formatComment bodyComments + ++ [ expr_ ] + ] + ) + + Src.Call func [] -> + formatExpression importInfo func + + Src.Call func ((( _, A.At (A.Region _ (A.Position firstArgEndRow _)) _ ) :: _) as args) -> + let + (A.Region (A.Position aexprStartRow _) _) = + region + + multiline : ElmStructure.FunctionApplicationMultiline + multiline = + if firstArgEndRow > aexprStartRow then + ElmStructure.FASplitFirst + + else + ElmStructure.FAJoinFirst + (if A.isMultiline region then + ElmStructure.SplitAll + + else + ElmStructure.JoinAll + ) + in + ( SpaceSeparated + , ElmStructure.application + multiline + (syntaxParens InfixSeparated <| formatExpression importInfo func) + (List.map (formatPreCommentedExpression importInfo SpaceSeparated) args) + ) + + Src.If ( _, if_ ) elseifs ( elsComments, els ) -> + let + opening : Box -> Box -> Box + opening key cond = + case ( key, cond ) of + ( Box.SingleLine key_, Box.SingleLine cond_ ) -> + Box.line <| + Box.row + [ key_ + , Box.space + , cond_ + , Box.space + , Box.keyword "then" + ] + + _ -> + Box.stack1 + [ key + , Box.indent cond + , Box.line (Box.keyword "then") + ] + + formatIf : ( Src.C2 Src.Expr, Src.C2 Src.Expr ) -> Box + formatIf ( cond, body ) = + Box.stack1 + [ opening (Box.line (Box.keyword "if")) (formatCommentedExpression importInfo cond) + , Box.indent <| formatCommented_ True <| Src.c2map (syntaxParens SyntaxSeparated << formatExpression importInfo) body + ] + + formatElseIf : Src.C1 ( Src.C2 Src.Expr, Src.C2 Src.Expr ) -> Box + formatElseIf ( ifComments, ( cond, body ) ) = + let + key : Box + key = + case formatPreCommented ( ifComments, Box.line (Box.keyword "if") ) of + Box.SingleLine key_ -> + Box.line <| Box.row [ Box.keyword "else", Box.space, key_ ] + + key_ -> + Box.stack1 + [ Box.line (Box.keyword "else") + , key_ + ] + in + Box.stack1 + [ Box.blankLine + , opening key <| formatCommentedExpression importInfo cond + , Box.indent <| formatCommented_ True <| Src.c2map (syntaxParens SyntaxSeparated << formatExpression importInfo) body + ] + in + ( AmbiguousEnd + , formatIf if_ + |> Box.andThen (List.map formatElseIf elseifs) + |> Box.andThen + [ Box.blankLine + , Box.line (Box.keyword "else") + , Box.indent <| formatCommented_ True <| Src.c2map (syntaxParens SyntaxSeparated << formatExpression importInfo) ( ( elsComments, [] ), els ) + ] + ) + + Src.Let defs bodyComments expr -> + let + letDeclarations : Src.C2 (A.Located Src.Def) -> List LetDeclaration + letDeclarations ( ( preDefComments, postDefComments ), A.At _ def ) = + let + ( typeAnnotation, commonDeclaration ) = + case def of + Src.Define (A.At nameRegion name) srcArgs ( comments, body ) maybeType -> + ( maybeType + |> Maybe.map + (\( postComments, ( ( preTypComments, postTypeComments ), typ ) ) -> + LetCommonDeclaration (TypeAnnotation ( preTypComments, VarRef () name ) ( postTypeComments, typ )) + :: List.map LetComment postComments + ) + |> Maybe.withDefault [] + , Definition (A.At nameRegion (Src.PVar name)) srcArgs comments body + ) + + Src.Destruct pattern ( comments, body ) -> + ( [], Definition pattern [] comments body ) + in + List.map LetComment preDefComments + ++ typeAnnotation + ++ LetCommonDeclaration commonDeclaration + :: List.map LetComment postDefComments + + spacer : LetDeclaration -> LetDeclaration -> List Box + spacer first _ = + case first of + LetCommonDeclaration (Definition _ _ _ _) -> + [ Box.blankLine ] + + _ -> + [] + + formatDefinition_ : LetDeclaration -> Box + formatDefinition_ def = + case def of + LetCommonDeclaration (Definition name args comments expr_) -> + formatDefinition importInfo name args comments expr_ + + LetCommonDeclaration (TypeAnnotation name typ) -> + formatTypeAnnotation name typ + + LetComment comment -> + formatComment comment + in + ( AmbiguousEnd + , -- TODO: not tested + Box.line (Box.keyword "let") + |> Box.andThen + (defs + |> List.concatMap letDeclarations + |> intersperseMap spacer formatDefinition_ + |> List.map Box.indent + ) + |> Box.andThen + [ Box.line (Box.keyword "in") + , Box.stack1 <| + List.map formatComment bodyComments + ++ [ syntaxParens SyntaxSeparated <| formatExpression importInfo expr ] + ] + ) + + Src.Case (( _, A.At subjectRegion _ ) as subject) clauses -> + let + opening : Box + opening = + case + ( A.isMultiline subjectRegion + , formatCommentedExpression importInfo subject + ) + of + ( False, Box.SingleLine subject_ ) -> + Box.line <| + Box.row + [ Box.keyword "case" + , Box.space + , subject_ + , Box.space + , Box.keyword "of" + ] + + ( _, subject_ ) -> + Box.stack1 + [ Box.line <| Box.keyword "case" + , Box.indent subject_ + , Box.line <| Box.keyword "of" + ] + + clause : ( Src.C2 Src.Pattern, Src.C1 Src.Expr ) -> Box + clause ( ( ( prePat, postPat ), A.At _ pat ), ( preExpr, expr ) ) = + case + ( ( postPat + , formatPattern pat + |> syntaxParens SyntaxSeparated + |> negativeCasePatternWorkaround pat + ) + , ( formatCommentedStack (Src.c2map (syntaxParens SyntaxSeparated << formatPattern) ( ( prePat, postPat ), pat )) + |> negativeCasePatternWorkaround pat + , formatPreCommentedStack <| Src.c1map (syntaxParens SyntaxSeparated << formatExpression importInfo) ( preExpr, expr ) + ) + ) + of + ( _, ( Box.SingleLine pat_, body_ ) ) -> + Box.stack1 + [ Box.line (Box.row [ pat_, Box.space, Box.keyword "->" ]) + , Box.indent body_ + ] + + ( ( [], Box.SingleLine pat_ ), ( _, body_ ) ) -> + Box.stack1 + (List.map formatComment prePat + ++ [ Box.line (Box.row [ pat_, Box.space, Box.keyword "->" ]) + , Box.indent body_ + ] + ) + + ( _, ( pat_, body_ ) ) -> + Box.stack1 + [ pat_ + , Box.line (Box.keyword "->") + , Box.indent body_ + ] + in + ( AmbiguousEnd + , -- TODO: not tested + opening + |> Box.andThen + (clauses + |> List.map clause + |> List.intersperse Box.blankLine + |> List.map Box.indent + ) + ) + + Src.Accessor field -> + ( SyntaxSeparated + , Box.line (Box.identifier ("." ++ formatVarName field)) + ) + + Src.Access record (A.At _ field) -> + ( SyntaxSeparated + , formatExpression importInfo record + |> syntaxParens SpaceSeparated + -- TODO: does this need a different context than SpaceSeparated? + |> Box.addSuffix (Box.row [ Box.punc ".", formatLowercaseIdentifier [] field ]) + ) + + Src.Update name ( trailing, fields ) -> + let + multiline : Src.ForceMultiline + multiline = + Src.ForceMultiline (A.isMultiline region) + + fields_ : List (Src.C2Eol (Src.Pair Name Src.Expr)) + fields_ = + List.map + (Src.c2EolMap + (\( ( nameComments, A.At _ name_ ), ( _, A.At exprRegion _ ) as expr ) -> + Src.Pair ( nameComments, name_ ) expr (Src.ForceMultiline (A.isMultiline exprRegion)) + ) + ) + fields + in + ( SyntaxSeparated + , formatRecordLike + (Just (Src.c2map (syntaxParens SyntaxSeparated << formatExpression importInfo) name)) + (List.map (Src.c2EolMap (formatPair "=" << Src.mapPair (formatLowercaseIdentifier []) (syntaxParens SyntaxSeparated << formatExpression importInfo))) fields_) + trailing + multiline + ) + + Src.Record ( trailing, fields ) -> + let + multiline : Src.ForceMultiline + multiline = + Src.ForceMultiline (A.isMultiline region) + + fields_ : List (Src.C2Eol (Src.Pair Name Src.Expr)) + fields_ = + List.map + (Src.c2EolMap + (\( ( nameComments, A.At nameRegion name_ ), ( _, A.At exprRegion _ ) as expr ) -> + Src.Pair ( nameComments, name_ ) expr (Src.ForceMultiline (A.isMultiline (A.mergeRegions nameRegion exprRegion))) + ) + ) + fields + in + ( SyntaxSeparated + , formatRecordLike Nothing + (List.map (Src.c2EolMap (formatPair "=" << Src.mapPair (formatLowercaseIdentifier []) (syntaxParens SyntaxSeparated << formatExpression importInfo))) fields_) + trailing + multiline + ) + + Src.Unit -> + ( SyntaxSeparated + , formatUnit '(' ')' [] + ) + + Src.Tuple a b cs -> + let + multiline : Bool + multiline = + A.isMultiline region + + exprs : List (Src.C2 Src.Expr) + exprs = + a :: b :: cs + in + ( SyntaxSeparated + , ElmStructure.group True "(" "," ")" multiline <| + List.map (formatCommentedExpression importInfo) exprs + ) + + Src.Shader (Shader.Source src) _ -> + ( SyntaxSeparated + , Box.line <| + Box.row + [ Box.punc "[glsl|" + , Box.literal (Shader.unescape src) + , Box.punc "|]" + ] + ) + + Src.Parens expr -> + case expr of + ( ( [], [] ), expr_ ) -> + formatExpression importInfo expr_ + + _ -> + ( SyntaxSeparated + , formatCommentedExpression importInfo expr + |> parens + ) + + +type LetDeclaration + = LetCommonDeclaration CommonDeclaration + | LetComment Src.FComment + + +formatCommentedExpression : ImportInfo -> Src.C2 Src.Expr -> Box +formatCommentedExpression importInfo ( ( pre, post ), e ) = + let + commented_ : Src.C2 Src.Expr + commented_ = + -- TODO + -- case e of + -- Src.Parens (C ( pre__, post__ ) e__) -> + -- ( pre ++ pre__, e__, post__ ++ post ) + -- _ -> + ( ( pre, post ), e ) + in + formatCommented <| Src.c2map (syntaxParens SyntaxSeparated << formatExpression importInfo) commented_ + + +formatPreCommentedExpression : ImportInfo -> SyntaxContext -> Src.C1 Src.Expr -> Box +formatPreCommentedExpression importInfo context ( pre, e ) = + let + ( pre_, e_ ) = + -- TODO + -- case e of + -- Parens (C ( pre__, [] ) e__) -> + -- ( pre ++ pre__, e__ ) + -- _ -> + ( pre, e ) + in + formatCommentedApostrophe pre_ (syntaxParens context <| formatExpression importInfo e_) + + +formatRecordLike : Maybe (Src.C2 Box) -> List (Src.C2Eol Box) -> Src.FComments -> Src.ForceMultiline -> Box +formatRecordLike base_ fields trailing multiline = + case ( base_, fields ) of + ( Just base, pairs_ ) -> + ElmStructure.extensionGroup_ + ((\(Src.ForceMultiline b) -> b) multiline) + (formatCommented base) + (formatSequence '|' + ',' + Nothing + multiline + trailing + pairs_ + ) + + ( Nothing, pairs_ ) -> + formatSequence '{' + ',' + (Just '}') + multiline + trailing + pairs_ + + +formatSequence : Char -> Char -> Maybe Char -> Src.ForceMultiline -> Src.FComments -> List (Src.C2Eol Box) -> Box +formatSequence left delim maybeRight (Src.ForceMultiline multiline) trailing list = + case ( maybeRight, list ) of + ( _, first :: rest ) -> + let + formatItem : Char -> Src.C2Eol Box -> Box + formatItem delim_ ( ( pre, post, eol ), item ) = + Maybe.unwrap identity (Box.stack_ << Box.stack_ Box.blankLine) (formatComments pre) <| + Box.prefix (Box.row [ Box.punc (String.fromChar delim_), Box.space ]) <| + formatC2Eol ( ( post, [], eol ), item ) + in + ElmStructure.forceableSpaceSepOrStack multiline + (ElmStructure.forceableRowOrStack multiline + (formatItem left first) + (List.map (formatItem delim) rest) + ) + (Maybe.unwrap [] (flip (::) [] << Box.stack_ Box.blankLine) (formatComments trailing) ++ Maybe.toList (Maybe.map (Box.line << Box.punc << String.fromChar) maybeRight)) + + ( Just right, [] ) -> + formatUnit left right trailing + + ( Nothing, [] ) -> + formatUnit left ' ' trailing + + +mapIsLast : (Bool -> a -> b) -> List a -> List b +mapIsLast f l = + case l of + [] -> + [] + + [ last_ ] -> + [ f True last_ ] + + next :: rest -> + f False next :: mapIsLast f rest + + +type BinopsClause varRef expr + = BinopsClause Src.FComments varRef Src.FComments expr + + +formatBinops : ImportInfo -> Src.Expr -> List (BinopsClause (Ref (List String)) Src.Expr) -> Bool -> Box +formatBinops importInfo left ops multiline = + let + formatPair_ : Bool -> BinopsClause (Ref (List String)) Src.Expr -> ( ( Bool, Src.FComments, Box ), Box ) + formatPair_ isLast (BinopsClause po o pe e) = + let + isLeftPipe : Bool + isLeftPipe = + o == OpRef "<|" + + formatContext : SyntaxContext + formatContext = + if isLeftPipe && isLast then + AmbiguousEnd + + else + InfixSeparated + in + ( ( isLeftPipe + , po + , (Box.line << formatInfixVar) o + ) + , formatCommentedApostrophe pe <| syntaxParens formatContext <| formatExpression importInfo e + ) + in + formatBinary + multiline + (syntaxParens InfixSeparated <| formatExpression importInfo left) + (mapIsLast formatPair_ ops) + + +formatUnit : Char -> Char -> Src.FComments -> Box +formatUnit left right comments = + case ( left, comments ) of + ( _, [] ) -> + Box.line <| Box.punc (String.fromList [ left, right ]) + + ( '{', (Src.LineComment _) :: _ ) -> + surround left right <| Box.prefix Box.space <| Box.stack1 <| List.map formatComment comments + + _ -> + surround left right <| + case Box.allSingles <| List.map formatComment comments of + Ok comments_ -> + Box.line <| Box.row <| List.intersperse Box.space comments_ + + Err comments_ -> + Box.stack1 comments_ + + +formatComments : Src.FComments -> Maybe Box +formatComments comments = + case List.map formatComment comments of + [] -> + Nothing + + first :: rest -> + Just (ElmStructure.spaceSepOrStack first rest) + + +formatCommented_ : Bool -> Src.C2 Box -> Box +formatCommented_ forceMultiline ( ( pre, post ), inner ) = + ElmStructure.forceableSpaceSepOrStack1 forceMultiline <| + List.concat + [ Maybe.toList (formatComments pre) + , [ inner ] + , Maybe.toList (formatComments post) + ] + + +formatCommented : Src.C2 Box -> Box +formatCommented = + formatCommented_ False + + +formatPreCommented : Src.C1 Box -> Box +formatPreCommented ( pre, inner ) = + formatCommentedApostrophe pre inner + + +formatCommentedApostrophe : Src.FComments -> Box -> Box +formatCommentedApostrophe pre inner = + formatCommented ( ( pre, [] ), inner ) + + +formatTailCommented : Src.C1 Box -> Box +formatTailCommented ( post, inner ) = + formatCommented ( ( [], post ), inner ) + + +formatC2Eol : Src.C2Eol Box -> Box +formatC2Eol ( ( pre, post, eol ), a ) = + formatCommented ( ( pre, post ), formatEolCommented ( eol, a ) ) + + +formatEolCommented : ( Maybe String, Box ) -> Box +formatEolCommented ( post, inner ) = + case ( post, inner ) of + ( Nothing, box ) -> + box + + ( Just eol, Box.SingleLine result ) -> + Box.mustBreak <| Box.row [ result, Box.space, Box.punc "--", Box.literal eol ] + + ( Just eol, box ) -> + Box.stack1 [ box, formatComment <| Src.LineComment eol ] + + +formatCommentedStack : Src.C2 Box -> Box +formatCommentedStack ( ( pre, post ), inner ) = + Box.stack1 <| + List.map formatComment pre + ++ inner + :: List.map formatComment post + + +formatPreCommentedStack : Src.C1 Box -> Box +formatPreCommentedStack ( pre, inner ) = + formatCommentedStack ( ( pre, [] ), inner ) + + +formatKeywordCommented : String -> Src.C2 Box -> Box +formatKeywordCommented word ( ( pre, post ), value ) = + ElmStructure.spaceSepOrIndented + (formatCommented ( ( pre, post ), Box.line (Box.keyword word) )) + [ value ] + + +formatOpenCommentedList : Src.OpenCommentedList Box -> List Box +formatOpenCommentedList (Src.OpenCommentedList rest ( preLst, eol, lst )) = + List.map formatC2Eol rest + ++ [ formatC2Eol ( ( preLst, [], eol ), lst ) ] + + +formatComment : Src.FComment -> Box +formatComment comment = + case comment of + Src.BlockComment c -> + case c of + [] -> + Box.line <| Box.punc "{- -}" + + [ l ] -> + Box.line <| + Box.row + [ Box.punc "{-" + , Box.space + , Box.literal (String.trim l) + , Box.space + , Box.punc "-}" + ] + + ls -> + Box.stack1 + [ Box.prefix + (Box.row [ Box.punc "{-", Box.space ]) + (Box.stack1 <| List.map (Box.line << Box.literal) ls) + , Box.line <| Box.punc "-}" + ] + + Src.LineComment c -> + Box.mustBreak <| Box.row [ Box.punc "--", Box.literal c ] + + Src.CommentTrickOpener -> + Box.mustBreak <| Box.punc "{--}" + + Src.CommentTrickCloser -> + Box.mustBreak <| Box.punc "--}" + + Src.CommentTrickBlock c -> + Box.mustBreak <| Box.row [ Box.punc "{--", Box.literal c, Box.punc "-}" ] + + +type StringRepresentation + = SingleQuotedString + | TripleQuotedString + + +type LiteralValue + = IntNum String + | FloatNum String + | Boolean Bool + + +formatLiteral : LiteralValue -> Box +formatLiteral lit = + case lit of + IntNum i -> + let + number : String + number = + if String.startsWith "0x" i then + "0x" ++ String.toUpper (String.dropLeft 2 i) + + else + i + in + Box.line (Box.literal number) + + FloatNum f -> + Box.line (Box.literal f) + + Boolean True -> + Box.line <| Box.literal "True" + + Boolean False -> + Box.line <| Box.literal "False" + + +type StringStyle + = SChar + | SString StringRepresentation + + +charIsPrint : Char -> Bool +charIsPrint c = + case c of + '\u{2028}' -> + False + + '\u{2029}' -> + False + + _ -> + True + + +formatString : StringStyle -> String -> Box +formatString style s = + let + stringBox : String -> (String -> String) -> Box + stringBox quotes escaper = + Box.line <| + Box.row + [ Box.punc quotes + , Box.literal <| escaper fixedString + , Box.punc quotes + ] + + styleBasedFix : String -> String + styleBasedFix = + case style of + SChar -> + String.replace "\\\"" "\"" + >> String.replace "\t" "\\t" + + SString TripleQuotedString -> + String.replace "\\n" "\n" + >> String.replace "\\\"" "\"" + >> String.replace "\\'" "'" + >> String.replace "\t" "\\t" + + SString SingleQuotedString -> + String.replace "\\'" "'" + + fixedString : String + fixedString = + s + |> styleBasedFix + |> String.replace "\t" "\\t" + |> String.toList + |> List.map + (\c -> + if not (charIsPrint c) then + hex c + + else + String.fromChar c + ) + |> String.concat + + hex : Char -> String + hex char = + "\\u{" ++ String.padLeft 4 '0' (Hex.toString (Char.toCode char)) ++ "}" + in + case style of + SChar -> + stringBox "'" identity + + SString SingleQuotedString -> + stringBox "\"" identity + + SString TripleQuotedString -> + let + escapeMultiQuote : String -> String + escapeMultiQuote = + let + step : String -> Int -> String -> String + step okay quotes remaining = + case String.toList remaining of + [] -> + String.reverse (String.repeat quotes "\"\\" ++ okay) + + next :: rest -> + if next == '"' then + step okay (quotes + 1) (String.fromList rest) + + else if quotes >= 3 then + step (String.cons next (String.repeat quotes "\"\\") ++ okay) 0 (String.fromList rest) + + else if quotes > 0 then + step (String.cons next (String.fromList (List.repeat quotes '"') ++ okay)) 0 (String.fromList rest) + + else + step (String.cons next okay) 0 (String.fromList rest) + in + step "" 0 + in + stringBox "\"\"\"" escapeMultiQuote + + +type TypeParensRequired + = {- 0 -} NotRequired + | {- 1 -} ForLambda + | {- 2 -} ForCtor + + +type TypeParensInner + = NotNeeded + | ForFunctionType + | ForTypeConstruction + + +typeParens : TypeParensRequired -> ( TypeParensInner, Box ) -> Box +typeParens outer ( inner, box ) = + if typeParensNeeded outer inner then + parens box + + else + box + + +typeParensNeeded : TypeParensRequired -> TypeParensInner -> Bool +typeParensNeeded outer typeParensInner = + case typeParensInner of + NotNeeded -> + False + + ForTypeConstruction -> + -- outer >= ForCtor + outer == ForCtor + + ForFunctionType -> + -- outer >= ForLambda + outer == ForLambda || outer == ForCtor + + +formatTypeConstructor : String -> Box +formatTypeConstructor name = + Box.line <| formatQualifiedUppercaseIdentifier (String.split "." name) + + +formatType : Src.Type -> ( TypeParensInner, Box ) +formatType (A.At region atype) = + case atype of + Src.TLambda first result -> + let + rest : List (Src.C2Eol Src.Type) + rest = + let + go : Src.C2Eol Src.Type -> List (Src.C2Eol Src.Type) -> List (Src.C2Eol Src.Type) + go ( comments, type_ ) acc = + case type_ of + A.At _ (Src.TLambda ( _, subFirst ) subRest) -> + go subRest (acc ++ [ ( comments, subFirst ) ]) + + _ -> + acc ++ [ ( comments, type_ ) ] + in + go result [] + + forceMultiline : Bool + forceMultiline = + A.isMultiline region + + formatRight : Src.C2Eol Src.Type -> Box + formatRight ( ( preOp, postOp, eol ), term ) = + ElmStructure.forceableSpaceSepOrStack1 False <| + ((Maybe.toList <| formatComments preOp) + ++ [ ElmStructure.prefixOrIndented + (Box.line <| Box.punc "->") + (formatC2Eol <| + (Src.c2EolMap <| typeParens ForLambda << formatType) + ( ( postOp, [], eol ), term ) + ) + ] + ) + in + ( ForFunctionType + , ElmStructure.forceableSpaceSepOrStack + forceMultiline + (formatEolCommented (Src.c0EolMap (typeParens ForLambda << formatType) first)) + (List.map formatRight rest) + ) + + Src.TVar name -> + ( NotNeeded + , Box.line <| + Box.identifier <| + formatVarName name + ) + + Src.TType _ ctor args -> + let + forceMultiline : Src.ForceMultiline + forceMultiline = + Src.ForceMultiline (A.isMultiline region) + + join : ElmStructure.FunctionApplicationMultiline + join = + case forceMultiline of + Src.ForceMultiline True -> + ElmStructure.FASplitFirst + + Src.ForceMultiline False -> + ElmStructure.FAJoinFirst ElmStructure.JoinAll + in + ( if List.isEmpty args then + NotNeeded + + else + ForTypeConstruction + , ElmStructure.application + join + (formatTypeConstructor ctor) + (List.map (formatPreCommented << Src.c1map (typeParens ForCtor << formatType)) args) + ) + + Src.TTypeQual _ home name args -> + let + forceMultiline : Src.ForceMultiline + forceMultiline = + Src.ForceMultiline (A.isMultiline region) + + join : ElmStructure.FunctionApplicationMultiline + join = + case forceMultiline of + Src.ForceMultiline True -> + ElmStructure.FASplitFirst + + Src.ForceMultiline False -> + ElmStructure.FAJoinFirst ElmStructure.JoinAll + in + ( if List.isEmpty args then + NotNeeded + + else + ForTypeConstruction + , ElmStructure.application + join + (formatTypeConstructor (home ++ "." ++ name)) + (List.map (formatPreCommented << Src.c1map (typeParens ForCtor << formatType)) args) + ) + + Src.TRecord fields ext trailing -> + let + base : Maybe (Src.C2 Name) + base = + Maybe.map (Src.c2map A.toValue) ext + + fields_ : List (Src.C2Eol (Src.Pair Name Src.Type)) + fields_ = + List.map + (\( ( preFieldComments, postFieldComments ), ( ( postNameComments, A.At _ name ), ( preTypeComments, typ ) ) ) -> + ( ( preFieldComments, postFieldComments, Nothing ) + , Src.Pair ( postNameComments, name ) ( preTypeComments, typ ) (Src.ForceMultiline False) + ) + ) + fields + + multiline : Src.ForceMultiline + multiline = + Src.ForceMultiline (A.isMultiline region) + in + ( NotNeeded + , formatRecordLike + (Maybe.map (Src.c2map (Box.line << formatLowercaseIdentifier [])) base) + (List.map (Src.c2EolMap (formatPair ":" << Src.mapPair (formatLowercaseIdentifier []) (typeParens NotRequired << formatType))) fields_) + trailing + multiline + ) + + Src.TUnit -> + ( NotNeeded + , formatUnit '(' ')' [] + ) + + Src.TTuple a b cs -> + let + types : List (Src.C2Eol Src.Type) + types = + a :: b :: cs + + forceMultiline : Bool + forceMultiline = + A.isMultiline region + in + ( NotNeeded + , ElmStructure.group True "(" "," ")" forceMultiline (List.map (formatC2Eol << Src.c2EolMap (typeParens NotRequired << formatType)) types) + ) + + Src.TParens type_ -> + ( NotNeeded + , parens <| formatCommented <| Src.c2map (typeParens NotRequired << formatType) type_ + ) + + +formatVar : Ref (List String) -> Box.Line +formatVar var = + case var of + VarRef namespace name -> + formatLowercaseIdentifier namespace name + + TagRef namespace name -> + case namespace of + [] -> + Box.identifier (formatVarName name) + + _ -> + Box.row + [ formatQualifiedUppercaseIdentifier namespace + , Box.punc "." + , Box.identifier (formatVarName name) + ] + + OpRef name -> + formatSymbolIdentifierInParens name + + +formatSymbolIdentifierInParens : String -> Box.Line +formatSymbolIdentifierInParens name = + Box.identifier <| "(" ++ name ++ ")" + + +formatInfixVar : Ref (List String) -> Box.Line +formatInfixVar var = + case var of + VarRef _ _ -> + Box.row + [ Box.punc "`" + , formatVar var + , Box.punc "`" + ] + + TagRef _ _ -> + Box.row + [ Box.punc "`" + , formatVar var + , Box.punc "`" + ] + + OpRef name -> + Box.identifier name + + +formatLowercaseIdentifier : List String -> String -> Box.Line +formatLowercaseIdentifier namespace name = + case ( namespace, name ) of + ( [], _ ) -> + Box.identifier (formatVarName name) + + _ -> + Box.row + [ formatQualifiedUppercaseIdentifier namespace + , Box.punc "." + , Box.identifier (formatVarName name) + ] + + +formatUppercaseIdentifier : String -> Box.Line +formatUppercaseIdentifier name = + Box.identifier (formatVarName name) + + +formatQualifiedUppercaseIdentifier : List String -> Box.Line +formatQualifiedUppercaseIdentifier names = + Box.identifier <| + String.join "." <| + List.map formatVarName names + + +formatVarName : String -> String +formatVarName name = + String.map + (\x -> + if x == '\'' then + '_' + + else + x + ) + name diff --git a/src/Common/Format/Render/ElmStructure.elm b/src/Common/Format/Render/ElmStructure.elm new file mode 100644 index 0000000000..bdfe0cee0c --- /dev/null +++ b/src/Common/Format/Render/ElmStructure.elm @@ -0,0 +1,389 @@ +module Common.Format.Render.ElmStructure exposing + ( FunctionApplicationMultiline(..) + , Multiline(..) + , application + , definition + , equalsPair + , extensionGroup + , extensionGroup_ + , forceableRowOrStack + , forceableSpaceSepOrIndented + , forceableSpaceSepOrStack + , forceableSpaceSepOrStack1 + , group + , group_ + , prefixOrIndented + , spaceSepOrIndented + , spaceSepOrPrefix + , spaceSepOrStack + ) + +import Common.Format.Box as Box exposing (Box) +import Utils.Crash exposing (crash) + + +{-| Same as `forceableSpaceSepOrStack False` +-} +spaceSepOrStack : Box -> List Box -> Box +spaceSepOrStack = + forceableSpaceSepOrStack False + + +{-| Formats as: + + first rest0 rest1 + + first + + rest0 + + rest1 + +-} +forceableSpaceSepOrStack : Bool -> Box -> List Box -> Box +forceableSpaceSepOrStack forceMultiline first rest = + case + ( forceMultiline, first, Box.allSingles rest ) + of + ( False, Box.SingleLine first_, Ok rest_ ) -> + Box.line <| Box.row <| List.intersperse Box.space (first_ :: rest_) + + _ -> + Box.stack1 (first :: rest) + + +forceableRowOrStack : Bool -> Box -> List Box -> Box +forceableRowOrStack forceMultiline first rest = + case ( forceMultiline, first, Box.allSingles rest ) of + ( False, Box.SingleLine first_, Ok rest_ ) -> + Box.line <| Box.row (first_ :: rest_) + + _ -> + Box.stack1 (first :: rest) + + +{-| Same as `forceableSpaceSepOrStack` +-} +forceableSpaceSepOrStack1 : Bool -> List Box -> Box +forceableSpaceSepOrStack1 forceMultiline boxes = + case boxes of + first :: rest -> + forceableSpaceSepOrStack forceMultiline first rest + + _ -> + crash "forceableSpaceSepOrStack1 with empty list" + + +{-| Formats as: + + first rest0 rest1 rest2 + + first + rest0 + rest1 + rest2 + +-} +spaceSepOrIndented : Box -> List Box -> Box +spaceSepOrIndented = + forceableSpaceSepOrIndented False + + +forceableSpaceSepOrIndented : Bool -> Box -> List Box -> Box +forceableSpaceSepOrIndented forceMultiline first rest = + case + ( forceMultiline, first, Box.allSingles rest ) + of + ( False, Box.SingleLine first_, Ok rest_ ) -> + Box.line <| Box.row <| List.intersperse Box.space (first_ :: rest_) + + _ -> + Box.stack1 + (first :: List.map Box.indent rest) + + +{-| Formats as: + + op rest + + op rest1 + rest2 + + opLong + rest + +-} +spaceSepOrPrefix : Box -> Box -> Box +spaceSepOrPrefix op rest = + case ( op, rest ) of + ( Box.SingleLine op_, Box.SingleLine rest_ ) -> + Box.line <| Box.row [ op_, Box.space, rest_ ] + + ( Box.SingleLine op_, _ ) -> + if Box.lineLength 0 op_ < 4 then + Box.prefix (Box.row [ op_, Box.space ]) rest + + else + Box.stack1 [ op, Box.indent rest ] + + _ -> + Box.stack1 [ op, Box.indent rest ] + + +prefixOrIndented : Box -> Box -> Box +prefixOrIndented a b = + case ( a, b ) of + ( Box.SingleLine a_, Box.SingleLine b_ ) -> + Box.line <| Box.row [ a_, Box.space, b_ ] + + ( Box.SingleLine a_, Box.MustBreak b_ ) -> + Box.mustBreak <| Box.row [ a_, Box.space, b_ ] + + _ -> + Box.stack1 [ a, Box.indent b ] + + +{-| Formats as: + + left = + right + left = + right + left = + right + +-} +equalsPair : String -> Bool -> Box -> Box -> Box +equalsPair symbol forceMultiline left right = + case ( forceMultiline, left, right ) of + ( False, Box.SingleLine left_, Box.SingleLine right_ ) -> + Box.line <| + Box.row + [ left_ + , Box.space + , Box.punc symbol + , Box.space + , right_ + ] + + ( _, Box.SingleLine left_, Box.MustBreak right_ ) -> + Box.mustBreak <| + Box.row + [ left_ + , Box.space + , Box.punc symbol + , Box.space + , right_ + ] + + ( _, Box.SingleLine left_, right_ ) -> + Box.stack1 + [ Box.line <| Box.row [ left_, Box.space, Box.punc symbol ] + , Box.indent right_ + ] + + ( _, left_, right_ ) -> + Box.stack1 + [ left_ + , Box.indent <| Box.line <| Box.punc symbol + , Box.indent right_ + ] + + +{-| An equalsPair where the left side is an application +-} +definition : String -> Bool -> Box -> List Box -> Box -> Box +definition symbol forceMultiline first rest = + equalsPair symbol + forceMultiline + (application (FAJoinFirst JoinAll) first rest) + + +{-| Formats as: + + first rest0 rest1 rest2 + + first rest0 + rest1 + rest2 + + first + rest0 + rest1 + rest2 + +-} +application : FunctionApplicationMultiline -> Box -> List Box -> Box +application forceMultiline first args = + case args of + [] -> + first + + arg0 :: rest -> + case + ( ( forceMultiline + , first + ) + , ( arg0 + , Box.allSingles rest + ) + ) + of + ( ( FAJoinFirst JoinAll, Box.SingleLine first_ ), ( Box.SingleLine arg0_, Ok rest_ ) ) -> + (first_ :: arg0_ :: rest_) + |> List.intersperse Box.space + |> Box.row + |> Box.line + + ( ( FAJoinFirst _, Box.SingleLine first_ ), ( Box.SingleLine arg0_, _ ) ) -> + Box.stack1 <| + Box.line (Box.row [ first_, Box.space, arg0_ ]) + :: List.map Box.indent rest + + _ -> + Box.stack1 <| + first + :: List.map Box.indent (arg0 :: rest) + + +{-| `group True '<' ';' '>'` formats as: + + <> + + < child0 > + + < child0; child1; child2 > + + < child0 + ; child1 + ; child2 + > + +-} +group : Bool -> String -> String -> String -> Bool -> List Box -> Box +group innerSpaces left sep right forceMultiline children = + group_ innerSpaces left sep [] right forceMultiline children + + +group_ : Bool -> String -> String -> List Box -> String -> Bool -> List Box -> Box +group_ innerSpaces left sep extraFooter right forceMultiline children = + case ( forceMultiline, Box.allSingles children, Box.allSingles extraFooter ) of + ( _, Ok [], Ok efs ) -> + Box.line <| Box.row <| List.concat [ [ Box.punc left ], efs, [ Box.punc right ] ] + + ( False, Ok ls, Ok efs ) -> + Box.line <| + Box.row <| + List.concat + [ if innerSpaces then + [ Box.punc left, Box.space ] + + else + [ Box.punc left ] + , List.intersperse (Box.row [ Box.punc sep, Box.space ]) (ls ++ efs) + , if innerSpaces then + [ Box.space, Box.punc right ] + + else + [ Box.punc right ] + ] + + _ -> + case children of + [] -> + -- TODO: might lose extraFooter in this case, but can that ever happen? + Box.line <| Box.row [ Box.punc left, Box.punc right ] + + first :: rest -> + Box.stack1 <| + Box.prefix (Box.row [ Box.punc left, Box.space ]) first + :: List.map (Box.prefix <| Box.row [ Box.punc sep, Box.space ]) rest + ++ extraFooter + ++ [ Box.line <| Box.punc right ] + + +{-| Formats as: + + { base | first } + + { base | first, rest0, rest1 } + + { base + | first + , rest0 + , rest1 + } + +-} +extensionGroup : Bool -> Box -> Box -> List Box -> Box +extensionGroup multiline base first rest = + case + ( multiline + , Box.isLine base + , Box.allSingles (first :: rest) + ) + of + ( False, Ok base_, Ok fields_ ) -> + Box.line <| + Box.row + [ Box.punc "{" + , Box.space + , base_ + , Box.space + , Box.punc "|" + , Box.space + , Box.row (List.intersperse (Box.row [ Box.punc ",", Box.space ]) fields_) + , Box.space + , Box.punc "}" + ] + + _ -> + Box.stack1 + [ Box.prefix (Box.row [ Box.punc "{", Box.space ]) base + , Box.stack1 + (Box.prefix (Box.row [ Box.punc "|", Box.space ]) first + :: List.map (Box.prefix (Box.row [ Box.punc ",", Box.space ])) rest + ) + |> Box.indent + , Box.line <| Box.punc "}" + ] + + +extensionGroup_ : Bool -> Box -> Box -> Box +extensionGroup_ multiline base fields = + case + ( multiline + , base + , fields + ) + of + ( False, Box.SingleLine base_, Box.SingleLine fields_ ) -> + Box.line <| + Box.row <| + List.intersperse Box.space + [ Box.punc "{" + , base_ + , fields_ + , Box.punc "}" + ] + + _ -> + Box.stack1 + [ Box.prefix (Box.row [ Box.punc "{", Box.space ]) base + , Box.indent fields + , Box.line <| Box.punc "}" + ] + + + +-- FROM `AST.V0_16` + + +type Multiline + = JoinAll + | SplitAll + + +type FunctionApplicationMultiline + = FASplitFirst + | FAJoinFirst Multiline diff --git a/src/Common/Format/Render/Markdown.elm b/src/Common/Format/Render/Markdown.elm new file mode 100644 index 0000000000..6a00622a58 --- /dev/null +++ b/src/Common/Format/Render/Markdown.elm @@ -0,0 +1,431 @@ +module Common.Format.Render.Markdown exposing + ( Context(..) + , LongestSpanResult(..) + , formatListItem + , formatMardownBlock + , formatMarkdown + , formatMarkdownInline + , formatMarkdown_ + , formatRef + , lines + , longestSpanOf + , mapWithPrev + , prefix + , prefix_ + ) + +import Common.Format.Cheapskate.Types exposing (Block(..), Blocks, CodeAttr(..), Inline(..), LinkTarget(..), ListType(..)) +import Maybe.Extra as Maybe +import Url +import Utils.Main as Utils + + +formatMarkdown : (String -> Maybe String) -> Blocks -> String +formatMarkdown formatCode blocks = + let + needsInitialBlanks : Bool + needsInitialBlanks = + case blocks of + (Para inlines) :: _ -> + case inlines of + (Str a) :: (Str b) :: _ -> + (a == "@") && (b == "docs") + + _ -> + False + + [] -> + False + + _ -> + True + + needsTrailingBlanks : Bool + needsTrailingBlanks = + case blocks of + [] -> + False + + _ :: [] -> + needsInitialBlanks + + _ -> + True + in + formatMarkdown_ formatCode False needsInitialBlanks needsTrailingBlanks blocks + + +mapWithPrev : (Maybe a -> a -> b) -> List a -> List b +mapWithPrev f list = + case list of + [] -> + [] + + first :: rest -> + f Nothing first :: List.map2 (\prev next -> f (Just prev) next) (first :: rest) rest + + +formatMarkdown_ : (String -> Maybe String) -> Bool -> Bool -> Bool -> List Block -> String +formatMarkdown_ formatCode isListItem needsInitialBlanks needsTrailingBlanks blocks = + let + intersperse : List String -> List String + intersperse = + case ( isListItem, blocks ) of + ( True, [ Para _, List _ _ _ ] ) -> + identity + + _ -> + List.intersperse "\n" + + contextFor : Maybe Block -> Context + contextFor prev = + case prev of + Just (List _ _ _) -> + AfterIndentedList + + _ -> + Normal + in + (if needsInitialBlanks then + "\n\n" + + else + "" + ) + ++ (String.concat <| intersperse <| mapWithPrev (\prev -> formatMardownBlock formatCode (contextFor prev)) blocks) + ++ (if needsTrailingBlanks then + "\n" + + else + "" + ) + + +type Context + = Normal + | AfterIndentedList + + +formatMardownBlock : (String -> Maybe String) -> Context -> Block -> String +formatMardownBlock formatCode context block = + case block of + ElmDocs terms -> + (String.join "\n" <| List.map (\term -> "@docs " ++ String.join ", " term) terms) ++ "\n" + + Para inlines -> + (String.concat <| List.map (formatMarkdownInline True) inlines) ++ "\n" + + Header level inlines -> + "\n" ++ String.repeat level "#" ++ " " ++ (String.concat <| List.map (formatMarkdownInline True) inlines) ++ "\n" + + Blockquote blocks -> + formatMarkdown_ formatCode False False False blocks + |> prefix_ "> " "> " + + List tight (Bullet _) items -> + String.concat <| + (if tight then + identity + + else + List.intersperse "\n" + ) + <| + List.map (prefix_ " - " " " << formatMarkdown_ formatCode True False False) items + + List tight (Numbered _ _) items -> + String.concat <| + (if tight then + identity + + else + List.intersperse "\n" + ) + <| + List.map (formatListItem formatCode) <| + List.indexedMap Tuple.pair items + + CodeBlock (CodeAttr { codeLang }) code -> + let + isElm : Bool + isElm = + codeLang == "elm" || codeLang == "" + + formatted : String + formatted = + Maybe.withDefault (ensureNewline code) <| + if isElm then + formatCode code + + else + Nothing + + ensureNewline : String -> String + ensureNewline text = + if String.endsWith "\n" text then + text + + else + text ++ "\n" + + canIndent : Bool + canIndent = + case context of + Normal -> + True + + AfterIndentedList -> + False + in + if isElm && canIndent then + Utils.unlines <| List.map (\line -> " " ++ line) <| lines formatted + + else + "```" ++ codeLang ++ "\n" ++ formatted ++ "```\n" + + HtmlBlock text -> + text ++ "\n" + + HRule -> + "---\n" + + ReferencesBlock refs -> + String.concat <| List.map formatRef refs + + +lines : String -> List String +lines str = + case List.reverse (String.lines str) of + "" :: rest -> + List.reverse rest + + result -> + List.reverse result + + +formatListItem : (String -> Maybe String) -> ( Int, Blocks ) -> String +formatListItem formatCode ( i, item ) = + let + pref : String + pref = + if i < 10 then + String.fromInt i ++ ". " + + else + String.fromInt i ++ ". " + in + prefix_ pref " " <| formatMarkdown_ formatCode True False False item + + +formatRef : ( String, String, String ) -> String +formatRef ( label, url, title ) = + "[" + ++ label + ++ "]: " + ++ url + ++ (if title == "" then + "" + + else + " \"" ++ title ++ "\"" + ) + ++ "\n" + + +prefix_ : String -> String -> String -> String +prefix_ preFirst preRest = + Utils.unlines << prefix preFirst preRest << lines + + +prefix : String -> String -> List String -> List String +prefix preFirst preRest list = + case list of + [] -> + [] + + first :: rest -> + (preFirst ++ first) :: List.map (\next -> preRest ++ next) rest + + +formatMarkdownInline : Bool -> Inline -> String +formatMarkdownInline fixSpecialChars inline = + let + fix : Char -> String + fix c = + case c of + '\\' -> + "\\\\" + + -- TODO: only at the beginning of words + '`' -> + "\\`" + + '_' -> + "\\_" + + '*' -> + "\\*" + + -- TODO: {} curly braces (when?) + -- TODO: [] square brackets (when?) + -- TODO: () parentheses (when?) + -- TODO: # hash mark (only at the beginning of lines, and within header lines?) + -- TODO: - minus sign (hyphen) (only at the beginning of lines?) + -- TODO: + plus sign (when?) + -- TODO: . dot (when?) + -- TODO: ! exclamation mark (when?) + _ -> + String.fromChar c + in + case inline of + Str text -> + (if fixSpecialChars then + String.concat << List.map fix << String.toList + + else + identity + ) + text + + Space -> + " " + + SoftBreak -> + "\n" + + LineBreak -> + "\n" + + Emph inlines -> + "_" ++ (String.concat <| List.map (formatMarkdownInline True) <| inlines) ++ "_" + + -- TODO: escaping + Strong inlines -> + "**" ++ (String.concat <| List.map (formatMarkdownInline True) <| inlines) ++ "**" + + -- TODO: escaping + Code text -> + case longestSpanOf '`' text of + NoSpan -> + "`" ++ text ++ "`" + + Span n -> + let + delimiter : String + delimiter = + String.repeat (n + 1) "`" + in + delimiter ++ " " ++ text ++ " " ++ delimiter + + Link inlines (Url url) title -> + let + textRaw : String + textRaw = + String.concat <| List.map (formatMarkdownInline False) inlines + + isValidAutolink : String -> Bool + isValidAutolink = + Url.fromString >> Maybe.isJust + in + if textRaw == url && title == "" && isValidAutolink url then + if fixSpecialChars then + "<" ++ url ++ ">" + + else + url + + else + let + text : String + text = + String.concat <| List.map (formatMarkdownInline fixSpecialChars) inlines + in + "[" + ++ text + ++ "](" + ++ url + ++ (if title == "" then + "" + + else + " \"" ++ title ++ "\"" + ) + ++ ")" + + Link inlines (Ref ref) _ -> + let + text : String + text = + String.concat <| List.map (formatMarkdownInline fixSpecialChars) inlines + in + if text == ref || ref == "" then + "[" ++ text ++ "]" + + else + "[" ++ text ++ "][" ++ ref ++ "]" + + Image inlines url title -> + "![" + ++ (String.concat <| List.map (formatMarkdownInline fixSpecialChars) inlines) + ++ "](" + ++ url + ++ (if title == "" then + "" + + else + " \"" ++ title ++ "\"" + ) + ++ ")" + + Entity text -> + text + + RawHtml text -> + text + + + +-- TEXT EXTRA + + +type LongestSpanResult + = NoSpan + | Span Int + + + +{- >= 1 -} + + +longestSpanOf : Char -> String -> LongestSpanResult +longestSpanOf char input = + let + step : Char -> ( Maybe Int, Int ) -> ( Maybe Int, Int ) + step c ( currentSpan, longest ) = + if c == char then + ( Just (1 + Maybe.withDefault 0 currentSpan) + , longest + ) + + else + ( -- clear the current span + Nothing + , -- and update the longest + endCurrentSpan ( currentSpan, longest ) + ) + + endCurrentSpan : ( Maybe Int, Int ) -> Int + endCurrentSpan acc = + case acc of + ( Nothing, longest ) -> + longest + + ( Just current, longest ) -> + max current longest + in + case String.foldl step ( Nothing, 0 ) input |> endCurrentSpan of + 0 -> + NoSpan + + positive -> + Span positive diff --git a/src/Compiler/AST/Canonical.elm b/src/Compiler/AST/Canonical.elm new file mode 100644 index 0000000000..54bf29e81b --- /dev/null +++ b/src/Compiler/AST/Canonical.elm @@ -0,0 +1,1203 @@ +module Compiler.AST.Canonical exposing + ( Alias(..) + , AliasType(..) + , Annotation(..) + , Binop(..) + , CaseBranch(..) + , Ctor(..) + , CtorOpts(..) + , Decls(..) + , Def(..) + , Effects(..) + , Export(..) + , Exports(..) + , Expr + , Expr_(..) + , FieldType(..) + , FieldUpdate(..) + , FreeVars + , Manager(..) + , Module(..) + , Pattern + , PatternCtorArg(..) + , Pattern_(..) + , Port(..) + , Type(..) + , Union(..) + , aliasDecoder + , aliasEncoder + , annotationDecoder + , annotationEncoder + , ctorOptsDecoder + , ctorOptsEncoder + , fieldUpdateDecoder + , fieldUpdateEncoder + , fieldsToList + , typeDecoder + , typeEncoder + , unionDecoder + , unionEncoder + ) + +{- Creating a canonical AST means finding the home module for all variables. + So if you have L.map, you need to figure out that it is from the elm/core + package in the List module. + + In later phases (e.g. type inference, exhaustiveness checking, optimization) + you need to look up additional info from these modules. What is the type? + What are the alternative type constructors? These lookups can be quite costly, + especially in type inference. To reduce costs the canonicalization phase + caches info needed in later phases. This means we no longer build large + dictionaries of metadata with O(log(n)) lookups in those phases. Instead + there is an O(1) read of an existing field! I have tried to mark all + cached data with comments like: + + -- CACHE for exhaustiveness + -- CACHE for inference + + So it is clear why the data is kept around. +-} + +import Compiler.AST.Source as Src +import Compiler.AST.Utils.Binop as Binop +import Compiler.AST.Utils.Shader as Shader +import Compiler.Data.Index as Index +import Compiler.Data.Name exposing (Name) +import Compiler.Elm.ModuleName as ModuleName +import Compiler.Reporting.Annotation as A +import Data.Map as Dict exposing (Dict) +import System.TypeCheck.IO as IO +import Utils.Bytes.Decode as BD +import Utils.Bytes.Encode as BE + + + +-- EXPRESSIONS + + +type alias Expr = + A.Located Expr_ + + + +-- CACHE Annotations for type inference + + +type Expr_ + = VarLocal Name + | VarTopLevel IO.Canonical Name + | VarKernel Name Name + | VarForeign IO.Canonical Name Annotation + | VarCtor CtorOpts IO.Canonical Name Index.ZeroBased Annotation + | VarDebug IO.Canonical Name Annotation + | VarOperator Name IO.Canonical Name Annotation -- CACHE real name for optimization + | Chr String + | Str String + | Int Int + | Float Float + | List (List Expr) + | Negate Expr + | Binop Name IO.Canonical Name Annotation Expr Expr -- CACHE real name for optimization + | Lambda (List Pattern) Expr + | Call Expr (List Expr) + | If (List ( Expr, Expr )) Expr + | Let Def Expr + | LetRec (List Def) Expr + | LetDestruct Pattern Expr Expr + | Case Expr (List CaseBranch) + | Accessor Name + | Access Expr (A.Located Name) + | Update Expr (Dict String (A.Located Name) FieldUpdate) + | Record (Dict String (A.Located Name) Expr) + | Unit + | Tuple Expr Expr (List Expr) + | Shader Shader.Source Shader.Types + + +type CaseBranch + = CaseBranch Pattern Expr + + +type FieldUpdate + = FieldUpdate A.Region Expr + + + +-- DEFS + + +type Def + = Def (A.Located Name) (List Pattern) Expr + | TypedDef (A.Located Name) FreeVars (List ( Pattern, Type )) Expr Type + + +type Decls + = Declare Def Decls + | DeclareRec Def (List Def) Decls + | SaveTheEnvironment + + + +-- PATTERNS + + +type alias Pattern = + A.Located Pattern_ + + +type Pattern_ + = PAnything + | PVar Name + | PRecord (List Name) + | PAlias Pattern Name + | PUnit + | PTuple Pattern Pattern (List Pattern) + | PList (List Pattern) + | PCons Pattern Pattern + | PBool Union Bool + | PChr String + | PStr String Bool + | PInt Int + | PCtor + -- CACHE p_home, p_type, and p_vars for type inference + -- CACHE p_index to replace p_name in PROD code gen + -- CACHE p_opts to allocate less in PROD code gen + -- CACHE p_alts and p_numAlts for exhaustiveness checker + { home : IO.Canonical + , type_ : Name + , union : Union + , name : Name + , index : Index.ZeroBased + , args : List PatternCtorArg + } + + +type PatternCtorArg + = PatternCtorArg + -- CACHE for destructors/errors + Index.ZeroBased + -- CACHE for type inference + Type + Pattern + + + +-- TYPES + + +type Annotation + = Forall FreeVars Type + + +type alias FreeVars = + Dict String Name () + + +type Type + = TLambda Type Type + | TVar Name + | TType IO.Canonical Name (List Type) + | TRecord (Dict String Name FieldType) (Maybe Name) + | TUnit + | TTuple Type Type (List Type) + | TAlias IO.Canonical Name (List ( Name, Type )) AliasType + + +type AliasType + = Holey Type + | Filled Type + + +type FieldType + = FieldType Int Type + + + +-- NOTE: The Word16 marks the source order, but it may not be available +-- for every canonical type. For example, if the canonical type is inferred +-- the orders will all be zeros. + + +fieldsToList : Dict String Name FieldType -> List ( Name, Type ) +fieldsToList fields = + let + getIndex : ( a, FieldType ) -> Int + getIndex ( _, FieldType index _ ) = + index + + dropIndex : ( a, FieldType ) -> ( a, Type ) + dropIndex ( name, FieldType _ tipe ) = + ( name, tipe ) + in + Dict.toList compare fields + |> List.sortBy getIndex + |> List.map dropIndex + + + +-- MODULES + + +type Module + = Module IO.Canonical Exports Src.Docs Decls (Dict String Name Union) (Dict String Name Alias) (Dict String Name Binop) Effects + + +type Alias + = Alias (List Name) Type + + +type Binop + = Binop_ Binop.Associativity Binop.Precedence Name + + +type Union + = Union + (List Name) + (List Ctor) + -- CACHE numAlts for exhaustiveness checking + Int + -- CACHE which optimizations are available + CtorOpts + + +type CtorOpts + = Normal + | Enum + | Unbox + + +type Ctor + = Ctor Name Index.ZeroBased Int (List Type) -- CACHE length args + + + +-- EXPORTS + + +type Exports + = ExportEverything A.Region + | Export (Dict String Name (A.Located Export)) + + +type Export + = ExportValue + | ExportBinop + | ExportAlias + | ExportUnionOpen + | ExportUnionClosed + | ExportPort + + +type Effects + = NoEffects + | Ports (Dict String Name Port) + | Manager A.Region A.Region A.Region Manager + + +type Port + = Incoming + { freeVars : FreeVars + , payload : Type + , func : Type + } + | Outgoing + { freeVars : FreeVars + , payload : Type + , func : Type + } + + +type Manager + = Cmd Name + | Sub Name + | Fx Name Name + + + +-- ENCODERS and DECODERS + + +annotationEncoder : Annotation -> BE.Encoder +annotationEncoder (Forall freeVars tipe) = + BE.sequence + [ freeVarsEncoder freeVars + , typeEncoder tipe + ] + + +annotationDecoder : BD.Decoder Annotation +annotationDecoder = + BD.map2 Forall + freeVarsDecoder + typeDecoder + + +freeVarsEncoder : FreeVars -> BE.Encoder +freeVarsEncoder freeVars = + BE.list BE.string (Dict.keys compare freeVars) + + +freeVarsDecoder : BD.Decoder FreeVars +freeVarsDecoder = + BD.list BD.string + |> BD.map (List.map (\key -> ( key, () )) >> Dict.fromList identity) + + +aliasEncoder : Alias -> BE.Encoder +aliasEncoder (Alias vars tipe) = + BE.sequence + [ BE.list BE.string vars + , typeEncoder tipe + ] + + +aliasDecoder : BD.Decoder Alias +aliasDecoder = + BD.map2 Alias + (BD.list BD.string) + typeDecoder + + +typeEncoder : Type -> BE.Encoder +typeEncoder type_ = + case type_ of + TLambda a b -> + BE.sequence + [ BE.unsignedInt8 0 + , typeEncoder a + , typeEncoder b + ] + + TVar name -> + BE.sequence + [ BE.unsignedInt8 1 + , BE.string name + ] + + TType home name args -> + BE.sequence + [ BE.unsignedInt8 2 + , ModuleName.canonicalEncoder home + , BE.string name + , BE.list typeEncoder args + ] + + TRecord fields ext -> + BE.sequence + [ BE.unsignedInt8 3 + , BE.assocListDict compare BE.string fieldTypeEncoder fields + , BE.maybe BE.string ext + ] + + TUnit -> + BE.unsignedInt8 4 + + TTuple a b cs -> + BE.sequence + [ BE.unsignedInt8 5 + , typeEncoder a + , typeEncoder b + , BE.list typeEncoder cs + ] + + TAlias home name args tipe -> + BE.sequence + [ BE.unsignedInt8 6 + , ModuleName.canonicalEncoder home + , BE.string name + , BE.list (BE.jsonPair BE.string typeEncoder) args + , aliasTypeEncoder tipe + ] + + +typeDecoder : BD.Decoder Type +typeDecoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.map2 TLambda + typeDecoder + typeDecoder + + 1 -> + BD.map TVar BD.string + + 2 -> + BD.map3 TType + ModuleName.canonicalDecoder + BD.string + (BD.list typeDecoder) + + 3 -> + BD.map2 TRecord + (BD.assocListDict identity BD.string fieldTypeDecoder) + (BD.maybe BD.string) + + 4 -> + BD.succeed TUnit + + 5 -> + BD.map3 TTuple + typeDecoder + typeDecoder + (BD.list typeDecoder) + + 6 -> + BD.map4 TAlias + ModuleName.canonicalDecoder + BD.string + (BD.list (BD.jsonPair BD.string typeDecoder)) + aliasTypeDecoder + + _ -> + BD.fail + ) + + +fieldTypeEncoder : FieldType -> BE.Encoder +fieldTypeEncoder (FieldType index tipe) = + BE.sequence + [ BE.int index + , typeEncoder tipe + ] + + +aliasTypeEncoder : AliasType -> BE.Encoder +aliasTypeEncoder aliasType = + case aliasType of + Holey tipe -> + BE.sequence + [ BE.unsignedInt8 0 + , typeEncoder tipe + ] + + Filled tipe -> + BE.sequence + [ BE.unsignedInt8 1 + , typeEncoder tipe + ] + + +fieldTypeDecoder : BD.Decoder FieldType +fieldTypeDecoder = + BD.map2 FieldType + BD.int + typeDecoder + + +aliasTypeDecoder : BD.Decoder AliasType +aliasTypeDecoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.map Holey typeDecoder + + 1 -> + BD.map Filled typeDecoder + + _ -> + BD.fail + ) + + +unionEncoder : Union -> BE.Encoder +unionEncoder (Union vars ctors numAlts opts) = + BE.sequence + [ BE.list BE.string vars + , BE.list ctorEncoder ctors + , BE.int numAlts + , ctorOptsEncoder opts + ] + + +unionDecoder : BD.Decoder Union +unionDecoder = + BD.map4 Union + (BD.list BD.string) + (BD.list ctorDecoder) + BD.int + ctorOptsDecoder + + +ctorEncoder : Ctor -> BE.Encoder +ctorEncoder (Ctor ctor index numArgs args) = + BE.sequence + [ BE.string ctor + , Index.zeroBasedEncoder index + , BE.int numArgs + , BE.list typeEncoder args + ] + + +ctorDecoder : BD.Decoder Ctor +ctorDecoder = + BD.map4 Ctor + BD.string + Index.zeroBasedDecoder + BD.int + (BD.list typeDecoder) + + +ctorOptsEncoder : CtorOpts -> BE.Encoder +ctorOptsEncoder ctorOpts = + BE.unsignedInt8 + (case ctorOpts of + Normal -> + 0 + + Enum -> + 1 + + Unbox -> + 2 + ) + + +ctorOptsDecoder : BD.Decoder CtorOpts +ctorOptsDecoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.succeed Normal + + 1 -> + BD.succeed Enum + + 2 -> + BD.succeed Unbox + + _ -> + BD.fail + ) + + +fieldUpdateEncoder : FieldUpdate -> BE.Encoder +fieldUpdateEncoder (FieldUpdate fieldRegion expr) = + BE.sequence + [ A.regionEncoder fieldRegion + , exprEncoder expr + ] + + +fieldUpdateDecoder : BD.Decoder FieldUpdate +fieldUpdateDecoder = + BD.map2 FieldUpdate + A.regionDecoder + exprDecoder + + +exprEncoder : Expr -> BE.Encoder +exprEncoder = + A.locatedEncoder expr_Encoder + + +exprDecoder : BD.Decoder Expr +exprDecoder = + A.locatedDecoder expr_Decoder + + +expr_Encoder : Expr_ -> BE.Encoder +expr_Encoder expr_ = + case expr_ of + VarLocal name -> + BE.sequence + [ BE.unsignedInt8 0 + , BE.string name + ] + + VarTopLevel home name -> + BE.sequence + [ BE.unsignedInt8 1 + , ModuleName.canonicalEncoder home + , BE.string name + ] + + VarKernel home name -> + BE.sequence + [ BE.unsignedInt8 2 + , BE.string home + , BE.string name + ] + + VarForeign home name annotation -> + BE.sequence + [ BE.unsignedInt8 3 + , ModuleName.canonicalEncoder home + , BE.string name + , annotationEncoder annotation + ] + + VarCtor opts home name index annotation -> + BE.sequence + [ BE.unsignedInt8 4 + , ctorOptsEncoder opts + , ModuleName.canonicalEncoder home + , BE.string name + , Index.zeroBasedEncoder index + , annotationEncoder annotation + ] + + VarDebug home name annotation -> + BE.sequence + [ BE.unsignedInt8 5 + , ModuleName.canonicalEncoder home + , BE.string name + , annotationEncoder annotation + ] + + VarOperator op home name annotation -> + BE.sequence + [ BE.unsignedInt8 6 + , BE.string op + , ModuleName.canonicalEncoder home + , BE.string name + , annotationEncoder annotation + ] + + Chr chr -> + BE.sequence + [ BE.unsignedInt8 7 + , BE.string chr + ] + + Str str -> + BE.sequence + [ BE.unsignedInt8 8 + , BE.string str + ] + + Int int -> + BE.sequence + [ BE.unsignedInt8 9 + , BE.int int + ] + + Float float -> + BE.sequence + [ BE.unsignedInt8 10 + , BE.float float + ] + + List entries -> + BE.sequence + [ BE.unsignedInt8 11 + , BE.list exprEncoder entries + ] + + Negate expr -> + BE.sequence + [ BE.unsignedInt8 12 + , exprEncoder expr + ] + + Binop op home name annotation left right -> + BE.sequence + [ BE.unsignedInt8 13 + , BE.string op + , ModuleName.canonicalEncoder home + , BE.string name + , annotationEncoder annotation + , exprEncoder left + , exprEncoder right + ] + + Lambda args body -> + BE.sequence + [ BE.unsignedInt8 14 + , BE.list patternEncoder args + , exprEncoder body + ] + + Call func args -> + BE.sequence + [ BE.unsignedInt8 15 + , exprEncoder func + , BE.list exprEncoder args + ] + + If branches finally -> + BE.sequence + [ BE.unsignedInt8 16 + , BE.list (BE.jsonPair exprEncoder exprEncoder) branches + , exprEncoder finally + ] + + Let def body -> + BE.sequence + [ BE.unsignedInt8 17 + , defEncoder def + , exprEncoder body + ] + + LetRec defs body -> + BE.sequence + [ BE.unsignedInt8 18 + , BE.list defEncoder defs + , exprEncoder body + ] + + LetDestruct pattern expr body -> + BE.sequence + [ BE.unsignedInt8 19 + , patternEncoder pattern + , exprEncoder expr + , exprEncoder body + ] + + Case expr branches -> + BE.sequence + [ BE.unsignedInt8 20 + , exprEncoder expr + , BE.list caseBranchEncoder branches + ] + + Accessor field -> + BE.sequence + [ BE.unsignedInt8 21 + , BE.string field + ] + + Access record field -> + BE.sequence + [ BE.unsignedInt8 22 + , exprEncoder record + , A.locatedEncoder BE.string field + ] + + Update record updates -> + BE.sequence + [ BE.unsignedInt8 23 + , exprEncoder record + , BE.assocListDict A.compareLocated (A.toValue >> BE.string) fieldUpdateEncoder updates + ] + + Record fields -> + BE.sequence + [ BE.unsignedInt8 24 + , BE.assocListDict A.compareLocated (A.toValue >> BE.string) exprEncoder fields + ] + + Unit -> + BE.unsignedInt8 25 + + Tuple a b cs -> + BE.sequence + [ BE.unsignedInt8 26 + , exprEncoder a + , exprEncoder b + , BE.list exprEncoder cs + ] + + Shader src types -> + BE.sequence + [ BE.unsignedInt8 27 + , Shader.sourceEncoder src + , Shader.typesEncoder types + ] + + +expr_Decoder : BD.Decoder Expr_ +expr_Decoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.map VarLocal BD.string + + 1 -> + BD.map2 VarTopLevel + ModuleName.canonicalDecoder + BD.string + + 2 -> + BD.map2 VarKernel + BD.string + BD.string + + 3 -> + BD.map3 VarForeign + ModuleName.canonicalDecoder + BD.string + annotationDecoder + + 4 -> + BD.map5 VarCtor + ctorOptsDecoder + ModuleName.canonicalDecoder + BD.string + Index.zeroBasedDecoder + annotationDecoder + + 5 -> + BD.map3 VarDebug + ModuleName.canonicalDecoder + BD.string + annotationDecoder + + 6 -> + BD.map4 VarOperator + BD.string + ModuleName.canonicalDecoder + BD.string + annotationDecoder + + 7 -> + BD.map Chr BD.string + + 8 -> + BD.map Str BD.string + + 9 -> + BD.map Int BD.int + + 10 -> + BD.map Float BD.float + + 11 -> + BD.map List (BD.list exprDecoder) + + 12 -> + BD.map Negate exprDecoder + + 13 -> + BD.map6 Binop + BD.string + ModuleName.canonicalDecoder + BD.string + annotationDecoder + exprDecoder + exprDecoder + + 14 -> + BD.map2 Lambda + (BD.list patternDecoder) + exprDecoder + + 15 -> + BD.map2 Call + exprDecoder + (BD.list exprDecoder) + + 16 -> + BD.map2 If + (BD.list (BD.jsonPair exprDecoder exprDecoder)) + exprDecoder + + 17 -> + BD.map2 Let + defDecoder + exprDecoder + + 18 -> + BD.map2 LetRec + (BD.list defDecoder) + exprDecoder + + 19 -> + BD.map3 LetDestruct + patternDecoder + exprDecoder + exprDecoder + + 20 -> + BD.map2 Case + exprDecoder + (BD.list caseBranchDecoder) + + 21 -> + BD.map Accessor BD.string + + 22 -> + BD.map2 Access + exprDecoder + (A.locatedDecoder BD.string) + + 23 -> + BD.map2 Update + exprDecoder + (BD.assocListDict A.toValue (A.locatedDecoder BD.string) fieldUpdateDecoder) + + 24 -> + BD.map Record + (BD.assocListDict A.toValue (A.locatedDecoder BD.string) exprDecoder) + + 25 -> + BD.succeed Unit + + 26 -> + BD.map3 Tuple + exprDecoder + exprDecoder + (BD.list exprDecoder) + + 27 -> + BD.map2 Shader + Shader.sourceDecoder + Shader.typesDecoder + + _ -> + BD.fail + ) + + +patternEncoder : Pattern -> BE.Encoder +patternEncoder = + A.locatedEncoder pattern_Encoder + + +patternDecoder : BD.Decoder Pattern +patternDecoder = + A.locatedDecoder pattern_Decoder + + +pattern_Encoder : Pattern_ -> BE.Encoder +pattern_Encoder pattern_ = + case pattern_ of + PAnything -> + BE.unsignedInt8 0 + + PVar name -> + BE.sequence + [ BE.unsignedInt8 1 + , BE.string name + ] + + PRecord names -> + BE.sequence + [ BE.unsignedInt8 2 + , BE.list BE.string names + ] + + PAlias pattern name -> + BE.sequence + [ BE.unsignedInt8 3 + , patternEncoder pattern + , BE.string name + ] + + PUnit -> + BE.unsignedInt8 4 + + PTuple pattern1 pattern2 otherPatterns -> + BE.sequence + [ BE.unsignedInt8 5 + , patternEncoder pattern1 + , patternEncoder pattern2 + , BE.list patternEncoder otherPatterns + ] + + PList patterns -> + BE.sequence + [ BE.unsignedInt8 6 + , BE.list patternEncoder patterns + ] + + PCons pattern1 pattern2 -> + BE.sequence + [ BE.unsignedInt8 7 + , patternEncoder pattern1 + , patternEncoder pattern2 + ] + + PBool union bool -> + BE.sequence + [ BE.unsignedInt8 8 + , unionEncoder union + , BE.bool bool + ] + + PChr chr -> + BE.sequence + [ BE.unsignedInt8 9 + , BE.string chr + ] + + PStr str multiline -> + BE.sequence + [ BE.unsignedInt8 10 + , BE.string str + , BE.bool multiline + ] + + PInt int -> + BE.sequence + [ BE.unsignedInt8 11 + , BE.int int + ] + + PCtor { home, type_, union, name, index, args } -> + BE.sequence + [ BE.unsignedInt8 12 + , ModuleName.canonicalEncoder home + , BE.string type_ + , unionEncoder union + , BE.string name + , Index.zeroBasedEncoder index + , BE.list patternCtorArgEncoder args + ] + + +pattern_Decoder : BD.Decoder Pattern_ +pattern_Decoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.succeed PAnything + + 1 -> + BD.map PVar + BD.string + + 2 -> + BD.map PRecord + (BD.list BD.string) + + 3 -> + BD.map2 PAlias + patternDecoder + BD.string + + 4 -> + BD.succeed PUnit + + 5 -> + BD.map3 PTuple + patternDecoder + patternDecoder + (BD.list patternDecoder) + + 6 -> + BD.map PList + (BD.list patternDecoder) + + 7 -> + BD.map2 PCons + patternDecoder + patternDecoder + + 8 -> + BD.map2 PBool + unionDecoder + BD.bool + + 9 -> + BD.map PChr BD.string + + 10 -> + BD.map2 PStr + BD.string + BD.bool + + 11 -> + BD.map PInt BD.int + + 12 -> + BD.map6 + (\home type_ union name index args -> + PCtor + { home = home + , type_ = type_ + , union = union + , name = name + , index = index + , args = args + } + ) + ModuleName.canonicalDecoder + BD.string + unionDecoder + BD.string + Index.zeroBasedDecoder + (BD.list patternCtorArgDecoder) + + _ -> + BD.fail + ) + + +patternCtorArgEncoder : PatternCtorArg -> BE.Encoder +patternCtorArgEncoder (PatternCtorArg index srcType pattern) = + BE.sequence + [ Index.zeroBasedEncoder index + , typeEncoder srcType + , patternEncoder pattern + ] + + +patternCtorArgDecoder : BD.Decoder PatternCtorArg +patternCtorArgDecoder = + BD.map3 PatternCtorArg + Index.zeroBasedDecoder + typeDecoder + patternDecoder + + +defEncoder : Def -> BE.Encoder +defEncoder def = + case def of + Def name args expr -> + BE.sequence + [ BE.unsignedInt8 0 + , A.locatedEncoder BE.string name + , BE.list patternEncoder args + , exprEncoder expr + ] + + TypedDef name freeVars typedArgs expr srcResultType -> + BE.sequence + [ BE.unsignedInt8 1 + , A.locatedEncoder BE.string name + , freeVarsEncoder freeVars + , BE.list (BE.jsonPair patternEncoder typeEncoder) typedArgs + , exprEncoder expr + , typeEncoder srcResultType + ] + + +defDecoder : BD.Decoder Def +defDecoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.map3 Def + (A.locatedDecoder BD.string) + (BD.list patternDecoder) + exprDecoder + + 1 -> + BD.map5 TypedDef + (A.locatedDecoder BD.string) + freeVarsDecoder + (BD.list (BD.jsonPair patternDecoder typeDecoder)) + exprDecoder + typeDecoder + + _ -> + BD.fail + ) + + +caseBranchEncoder : CaseBranch -> BE.Encoder +caseBranchEncoder (CaseBranch pattern expr) = + BE.sequence + [ patternEncoder pattern + , exprEncoder expr + ] + + +caseBranchDecoder : BD.Decoder CaseBranch +caseBranchDecoder = + BD.map2 CaseBranch + patternDecoder + exprDecoder diff --git a/src/Compiler/AST/Optimized.elm b/src/Compiler/AST/Optimized.elm new file mode 100644 index 0000000000..a3f9cdf512 --- /dev/null +++ b/src/Compiler/AST/Optimized.elm @@ -0,0 +1,1127 @@ +module Compiler.AST.Optimized exposing + ( Choice(..) + , Decider(..) + , Def(..) + , Destructor(..) + , EffectsType(..) + , Expr(..) + , Global(..) + , GlobalGraph(..) + , LocalGraph(..) + , Main(..) + , Node(..) + , Path(..) + , addGlobalGraph + , addKernel + , addLocalGraph + , compareGlobal + , empty + , globalGraphDecoder + , globalGraphEncoder + , localGraphDecoder + , localGraphEncoder + , toComparableGlobal + , toKernelGlobal + ) + +import Compiler.AST.Canonical as Can +import Compiler.AST.Utils.Shader as Shader +import Compiler.Data.Index as Index +import Compiler.Data.Name as Name exposing (Name) +import Compiler.Elm.Kernel as K +import Compiler.Elm.ModuleName as ModuleName +import Compiler.Elm.Package as Pkg +import Compiler.Optimize.DecisionTree as DT +import Compiler.Reporting.Annotation as A +import Data.Map as Dict exposing (Dict) +import Data.Set as EverySet exposing (EverySet) +import System.TypeCheck.IO as IO +import Utils.Bytes.Decode as BD +import Utils.Bytes.Encode as BE + + + +-- EXPRESSIONS + + +type Expr + = Bool A.Region Bool + | Chr A.Region String + | Str A.Region String + | Int A.Region Int + | Float A.Region Float + | VarLocal Name + | TrackedVarLocal A.Region Name + | VarGlobal A.Region Global + | VarEnum A.Region Global Index.ZeroBased + | VarBox A.Region Global + | VarCycle A.Region IO.Canonical Name + | VarDebug A.Region Name IO.Canonical (Maybe Name) + | VarKernel A.Region Name Name + | List A.Region (List Expr) + | Function (List Name) Expr + | TrackedFunction (List (A.Located Name)) Expr + | Call A.Region Expr (List Expr) + | TailCall Name (List ( Name, Expr )) + | If (List ( Expr, Expr )) Expr + | Let Def Expr + | Destruct Destructor Expr + | Case Name Name (Decider Choice) (List ( Int, Expr )) + | Accessor A.Region Name + | Access Expr A.Region Name + | Update A.Region Expr (Dict String (A.Located Name) Expr) + | Record (Dict String Name Expr) + | TrackedRecord A.Region (Dict String (A.Located Name) Expr) + | Unit + | Tuple A.Region Expr Expr (List Expr) + | Shader Shader.Source (EverySet String Name) (EverySet String Name) + + +type Global + = Global IO.Canonical Name + + +compareGlobal : Global -> Global -> Order +compareGlobal (Global home1 name1) (Global home2 name2) = + case compare name1 name2 of + LT -> + LT + + EQ -> + ModuleName.compareCanonical home1 home2 + + GT -> + GT + + +toComparableGlobal : Global -> List String +toComparableGlobal (Global home name) = + ModuleName.toComparableCanonical home ++ [ name ] + + + +-- DEFINITIONS + + +type Def + = Def A.Region Name Expr + | TailDef A.Region Name (List (A.Located Name)) Expr + + +type Destructor + = Destructor Name Path + + +type Path + = Index Index.ZeroBased Path + | ArrayIndex Int Path + | Field Name Path + | Unbox Path + | Root Name + + + +-- BRANCHING + + +type Decider a + = Leaf a + | Chain (List ( DT.Path, DT.Test )) (Decider a) (Decider a) + | FanOut DT.Path (List ( DT.Test, Decider a )) (Decider a) + + +type Choice + = Inline Expr + | Jump Int + + + +-- OBJECT GRAPH + + +type GlobalGraph + = GlobalGraph (Dict (List String) Global Node) (Dict String Name Int) + + +type LocalGraph + = LocalGraph + (Maybe Main) + -- PERF profile switching Global to Name + (Dict (List String) Global Node) + (Dict String Name Int) + + +type Main + = Static + | Dynamic Can.Type Expr + + +type Node + = Define Expr (EverySet (List String) Global) + | TrackedDefine A.Region Expr (EverySet (List String) Global) + | DefineTailFunc A.Region (List (A.Located Name)) Expr (EverySet (List String) Global) + | Ctor Index.ZeroBased Int + | Enum Index.ZeroBased + | Box + | Link Global + | Cycle (List Name) (List ( Name, Expr )) (List Def) (EverySet (List String) Global) + | Manager EffectsType + | Kernel (List K.Chunk) (EverySet (List String) Global) + | PortIncoming Expr (EverySet (List String) Global) + | PortOutgoing Expr (EverySet (List String) Global) + + +type EffectsType + = Cmd + | Sub + | Fx + + + +-- GRAPHS + + +empty : GlobalGraph +empty = + GlobalGraph Dict.empty Dict.empty + + +addGlobalGraph : GlobalGraph -> GlobalGraph -> GlobalGraph +addGlobalGraph (GlobalGraph nodes1 fields1) (GlobalGraph nodes2 fields2) = + GlobalGraph + (Dict.union nodes1 nodes2) + (Dict.union fields1 fields2) + + +addLocalGraph : LocalGraph -> GlobalGraph -> GlobalGraph +addLocalGraph (LocalGraph _ nodes1 fields1) (GlobalGraph nodes2 fields2) = + GlobalGraph + (Dict.union nodes1 nodes2) + (Dict.union fields1 fields2) + + +addKernel : Name -> List K.Chunk -> GlobalGraph -> GlobalGraph +addKernel shortName chunks (GlobalGraph nodes fields) = + let + global : Global + global = + toKernelGlobal shortName + + node : Node + node = + Kernel chunks (List.foldr addKernelDep EverySet.empty chunks) + in + GlobalGraph + (Dict.insert toComparableGlobal global node nodes) + (Dict.union (K.countFields chunks) fields) + + +addKernelDep : K.Chunk -> EverySet (List String) Global -> EverySet (List String) Global +addKernelDep chunk deps = + case chunk of + K.JS _ -> + deps + + K.ElmVar home name -> + EverySet.insert toComparableGlobal (Global home name) deps + + K.JsVar shortName _ -> + EverySet.insert toComparableGlobal (toKernelGlobal shortName) deps + + K.ElmField _ -> + deps + + K.JsField _ -> + deps + + K.JsEnum _ -> + deps + + K.Debug -> + deps + + K.Prod -> + deps + + +toKernelGlobal : Name.Name -> Global +toKernelGlobal shortName = + Global (IO.Canonical Pkg.kernel shortName) Name.dollar + + + +-- ENCODERS and DECODERS + + +globalGraphEncoder : GlobalGraph -> BE.Encoder +globalGraphEncoder (GlobalGraph nodes fields) = + BE.sequence + [ BE.assocListDict compareGlobal globalEncoder nodeEncoder nodes + , BE.assocListDict compare BE.string BE.int fields + ] + + +globalGraphDecoder : BD.Decoder GlobalGraph +globalGraphDecoder = + BD.map2 GlobalGraph + (BD.assocListDict toComparableGlobal globalDecoder nodeDecoder) + (BD.assocListDict identity BD.string BD.int) + + +localGraphEncoder : LocalGraph -> BE.Encoder +localGraphEncoder (LocalGraph main nodes fields) = + BE.sequence + [ BE.maybe mainEncoder main + , BE.assocListDict compareGlobal globalEncoder nodeEncoder nodes + , BE.assocListDict compare BE.string BE.int fields + ] + + +localGraphDecoder : BD.Decoder LocalGraph +localGraphDecoder = + BD.map3 LocalGraph + (BD.maybe mainDecoder) + (BD.assocListDict toComparableGlobal globalDecoder nodeDecoder) + (BD.assocListDict identity BD.string BD.int) + + +mainEncoder : Main -> BE.Encoder +mainEncoder main_ = + case main_ of + Static -> + BE.unsignedInt8 0 + + Dynamic msgType decoder -> + BE.sequence + [ BE.unsignedInt8 1 + , Can.typeEncoder msgType + , exprEncoder decoder + ] + + +mainDecoder : BD.Decoder Main +mainDecoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.succeed Static + + 1 -> + BD.map2 Dynamic + Can.typeDecoder + exprDecoder + + _ -> + BD.fail + ) + + +globalEncoder : Global -> BE.Encoder +globalEncoder (Global home name) = + BE.sequence + [ ModuleName.canonicalEncoder home + , BE.string name + ] + + +globalDecoder : BD.Decoder Global +globalDecoder = + BD.map2 Global + ModuleName.canonicalDecoder + BD.string + + +nodeEncoder : Node -> BE.Encoder +nodeEncoder node = + case node of + Define expr deps -> + BE.sequence + [ BE.unsignedInt8 0 + , exprEncoder expr + , BE.everySet compareGlobal globalEncoder deps + ] + + TrackedDefine region expr deps -> + BE.sequence + [ BE.unsignedInt8 1 + , A.regionEncoder region + , exprEncoder expr + , BE.everySet compareGlobal globalEncoder deps + ] + + DefineTailFunc region argNames body deps -> + BE.sequence + [ BE.unsignedInt8 2 + , A.regionEncoder region + , BE.list (A.locatedEncoder BE.string) argNames + , exprEncoder body + , BE.everySet compareGlobal globalEncoder deps + ] + + Ctor index arity -> + BE.sequence + [ BE.unsignedInt8 3 + , Index.zeroBasedEncoder index + , BE.int arity + ] + + Enum index -> + BE.sequence + [ BE.unsignedInt8 4 + , Index.zeroBasedEncoder index + ] + + Box -> + BE.unsignedInt8 5 + + Link linkedGlobal -> + BE.sequence + [ BE.unsignedInt8 6 + , globalEncoder linkedGlobal + ] + + Cycle names values functions deps -> + BE.sequence + [ BE.unsignedInt8 7 + , BE.list BE.string names + , BE.list (BE.jsonPair BE.string exprEncoder) values + , BE.list defEncoder functions + , BE.everySet compareGlobal globalEncoder deps + ] + + Manager effectsType -> + BE.sequence + [ BE.unsignedInt8 8 + , effectsTypeEncoder effectsType + ] + + Kernel chunks deps -> + BE.sequence + [ BE.unsignedInt8 9 + , BE.list K.chunkEncoder chunks + , BE.everySet compareGlobal globalEncoder deps + ] + + PortIncoming decoder deps -> + BE.sequence + [ BE.unsignedInt8 10 + , exprEncoder decoder + , BE.everySet compareGlobal globalEncoder deps + ] + + PortOutgoing encoder deps -> + BE.sequence + [ BE.unsignedInt8 11 + , exprEncoder encoder + , BE.everySet compareGlobal globalEncoder deps + ] + + +nodeDecoder : BD.Decoder Node +nodeDecoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.map2 Define + exprDecoder + (BD.everySet toComparableGlobal globalDecoder) + + 1 -> + BD.map3 TrackedDefine + A.regionDecoder + exprDecoder + (BD.everySet toComparableGlobal globalDecoder) + + 2 -> + BD.map4 DefineTailFunc + A.regionDecoder + (BD.list (A.locatedDecoder BD.string)) + exprDecoder + (BD.everySet toComparableGlobal globalDecoder) + + 3 -> + BD.map2 Ctor + Index.zeroBasedDecoder + BD.int + + 4 -> + BD.map Enum + Index.zeroBasedDecoder + + 5 -> + BD.succeed Box + + 6 -> + BD.map Link globalDecoder + + 7 -> + BD.map4 Cycle + (BD.list BD.string) + (BD.list (BD.jsonPair BD.string exprDecoder)) + (BD.list defDecoder) + (BD.everySet toComparableGlobal globalDecoder) + + 8 -> + BD.map Manager effectsTypeDecoder + + 9 -> + BD.map2 Kernel + (BD.list K.chunkDecoder) + (BD.everySet toComparableGlobal globalDecoder) + + 10 -> + BD.map2 PortIncoming + exprDecoder + (BD.everySet toComparableGlobal globalDecoder) + + 11 -> + BD.map2 PortOutgoing + exprDecoder + (BD.everySet toComparableGlobal globalDecoder) + + _ -> + BD.fail + ) + + +exprEncoder : Expr -> BE.Encoder +exprEncoder expr = + case expr of + Bool region value -> + BE.sequence + [ BE.unsignedInt8 0 + , A.regionEncoder region + , BE.bool value + ] + + Chr region value -> + BE.sequence + [ BE.unsignedInt8 1 + , A.regionEncoder region + , BE.string value + ] + + Str region value -> + BE.sequence + [ BE.unsignedInt8 2 + , A.regionEncoder region + , BE.string value + ] + + Int region value -> + BE.sequence + [ BE.unsignedInt8 3 + , A.regionEncoder region + , BE.int value + ] + + Float region value -> + BE.sequence + [ BE.unsignedInt8 4 + , A.regionEncoder region + , BE.float value + ] + + VarLocal value -> + BE.sequence + [ BE.unsignedInt8 5 + , BE.string value + ] + + TrackedVarLocal region value -> + BE.sequence + [ BE.unsignedInt8 6 + , A.regionEncoder region + , BE.string value + ] + + VarGlobal region value -> + BE.sequence + [ BE.unsignedInt8 7 + , A.regionEncoder region + , globalEncoder value + ] + + VarEnum region global index -> + BE.sequence + [ BE.unsignedInt8 8 + , A.regionEncoder region + , globalEncoder global + , Index.zeroBasedEncoder index + ] + + VarBox region value -> + BE.sequence + [ BE.unsignedInt8 9 + , A.regionEncoder region + , globalEncoder value + ] + + VarCycle region home name -> + BE.sequence + [ BE.unsignedInt8 10 + , A.regionEncoder region + , ModuleName.canonicalEncoder home + , BE.string name + ] + + VarDebug region name home unhandledValueName -> + BE.sequence + [ BE.unsignedInt8 11 + , A.regionEncoder region + , BE.string name + , ModuleName.canonicalEncoder home + , BE.maybe BE.string unhandledValueName + ] + + VarKernel region home name -> + BE.sequence + [ BE.unsignedInt8 12 + , A.regionEncoder region + , BE.string home + , BE.string name + ] + + List region value -> + BE.sequence + [ BE.unsignedInt8 13 + , A.regionEncoder region + , BE.list exprEncoder value + ] + + Function args body -> + BE.sequence + [ BE.unsignedInt8 14 + , BE.list BE.string args + , exprEncoder body + ] + + TrackedFunction args body -> + BE.sequence + [ BE.unsignedInt8 15 + , BE.list (A.locatedEncoder BE.string) args + , exprEncoder body + ] + + Call region func args -> + BE.sequence + [ BE.unsignedInt8 16 + , A.regionEncoder region + , exprEncoder func + , BE.list exprEncoder args + ] + + TailCall name args -> + BE.sequence + [ BE.unsignedInt8 17 + , BE.string name + , BE.list (BE.jsonPair BE.string exprEncoder) args + ] + + If branches final -> + BE.sequence + [ BE.unsignedInt8 18 + , BE.list (BE.jsonPair exprEncoder exprEncoder) branches + , exprEncoder final + ] + + Let def body -> + BE.sequence + [ BE.unsignedInt8 19 + , defEncoder def + , exprEncoder body + ] + + Destruct destructor body -> + BE.sequence + [ BE.unsignedInt8 20 + , destructorEncoder destructor + , exprEncoder body + ] + + Case label root decider jumps -> + BE.sequence + [ BE.unsignedInt8 21 + , BE.string label + , BE.string root + , deciderEncoder choiceEncoder decider + , BE.list (BE.jsonPair BE.int exprEncoder) jumps + ] + + Accessor region field -> + BE.sequence + [ BE.unsignedInt8 22 + , A.regionEncoder region + , BE.string field + ] + + Access record region field -> + BE.sequence + [ BE.unsignedInt8 23 + , exprEncoder record + , A.regionEncoder region + , BE.string field + ] + + Update region record fields -> + BE.sequence + [ BE.unsignedInt8 24 + , A.regionEncoder region + , exprEncoder record + , BE.assocListDict A.compareLocated (A.locatedEncoder BE.string) exprEncoder fields + ] + + Record value -> + BE.sequence + [ BE.unsignedInt8 25 + , BE.assocListDict compare BE.string exprEncoder value + ] + + TrackedRecord region value -> + BE.sequence + [ BE.unsignedInt8 26 + , A.regionEncoder region + , BE.assocListDict A.compareLocated (A.locatedEncoder BE.string) exprEncoder value + ] + + Unit -> + BE.unsignedInt8 27 + + Tuple region a b cs -> + BE.sequence + [ BE.unsignedInt8 28 + , A.regionEncoder region + , exprEncoder a + , exprEncoder b + , BE.list exprEncoder cs + ] + + Shader src attributes uniforms -> + BE.sequence + [ BE.unsignedInt8 29 + , Shader.sourceEncoder src + , BE.everySet compare BE.string attributes + , BE.everySet compare BE.string uniforms + ] + + +exprDecoder : BD.Decoder Expr +exprDecoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.map2 Bool + A.regionDecoder + BD.bool + + 1 -> + BD.map2 Chr + A.regionDecoder + BD.string + + 2 -> + BD.map2 Str + A.regionDecoder + BD.string + + 3 -> + BD.map2 Int + A.regionDecoder + BD.int + + 4 -> + BD.map2 Float + A.regionDecoder + BD.float + + 5 -> + BD.map VarLocal BD.string + + 6 -> + BD.map2 TrackedVarLocal + A.regionDecoder + BD.string + + 7 -> + BD.map2 VarGlobal + A.regionDecoder + globalDecoder + + 8 -> + BD.map3 VarEnum + A.regionDecoder + globalDecoder + Index.zeroBasedDecoder + + 9 -> + BD.map2 VarBox + A.regionDecoder + globalDecoder + + 10 -> + BD.map3 VarCycle + A.regionDecoder + ModuleName.canonicalDecoder + BD.string + + 11 -> + BD.map4 VarDebug + A.regionDecoder + BD.string + ModuleName.canonicalDecoder + (BD.maybe BD.string) + + 12 -> + BD.map3 VarKernel + A.regionDecoder + BD.string + BD.string + + 13 -> + BD.map2 List + A.regionDecoder + (BD.list exprDecoder) + + 14 -> + BD.map2 Function + (BD.list BD.string) + exprDecoder + + 15 -> + BD.map2 TrackedFunction + (BD.list (A.locatedDecoder BD.string)) + exprDecoder + + 16 -> + BD.map3 Call + A.regionDecoder + exprDecoder + (BD.list exprDecoder) + + 17 -> + BD.map2 TailCall + BD.string + (BD.list (BD.jsonPair BD.string exprDecoder)) + + 18 -> + BD.map2 If + (BD.list (BD.jsonPair exprDecoder exprDecoder)) + exprDecoder + + 19 -> + BD.map2 Let + defDecoder + exprDecoder + + 20 -> + BD.map2 Destruct + destructorDecoder + exprDecoder + + 21 -> + BD.map4 Case + BD.string + BD.string + (deciderDecoder choiceDecoder) + (BD.list (BD.jsonPair BD.int exprDecoder)) + + 22 -> + BD.map2 Accessor + A.regionDecoder + BD.string + + 23 -> + BD.map3 Access + exprDecoder + A.regionDecoder + BD.string + + 24 -> + BD.map3 Update + A.regionDecoder + exprDecoder + (BD.assocListDict A.toValue (A.locatedDecoder BD.string) exprDecoder) + + 25 -> + BD.map Record + (BD.assocListDict identity BD.string exprDecoder) + + 26 -> + BD.map2 TrackedRecord + A.regionDecoder + (BD.assocListDict A.toValue (A.locatedDecoder BD.string) exprDecoder) + + 27 -> + BD.succeed Unit + + 28 -> + BD.map4 Tuple + A.regionDecoder + exprDecoder + exprDecoder + (BD.list exprDecoder) + + 29 -> + BD.map3 Shader + Shader.sourceDecoder + (BD.everySet identity BD.string) + (BD.everySet identity BD.string) + + _ -> + BD.fail + ) + + +defEncoder : Def -> BE.Encoder +defEncoder def = + case def of + Def region name expr -> + BE.sequence + [ BE.unsignedInt8 0 + , A.regionEncoder region + , BE.string name + , exprEncoder expr + ] + + TailDef region name args expr -> + BE.sequence + [ BE.unsignedInt8 1 + , A.regionEncoder region + , BE.string name + , BE.list (A.locatedEncoder BE.string) args + , exprEncoder expr + ] + + +defDecoder : BD.Decoder Def +defDecoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.map3 Def + A.regionDecoder + BD.string + exprDecoder + + 1 -> + BD.map4 TailDef + A.regionDecoder + BD.string + (BD.list (A.locatedDecoder BD.string)) + exprDecoder + + _ -> + BD.fail + ) + + +destructorEncoder : Destructor -> BE.Encoder +destructorEncoder (Destructor name path) = + BE.sequence + [ BE.string name + , pathEncoder path + ] + + +destructorDecoder : BD.Decoder Destructor +destructorDecoder = + BD.map2 Destructor + BD.string + pathDecoder + + +deciderEncoder : (a -> BE.Encoder) -> Decider a -> BE.Encoder +deciderEncoder encoder decider = + case decider of + Leaf value -> + BE.sequence + [ BE.unsignedInt8 0 + , encoder value + ] + + Chain testChain success failure -> + BE.sequence + [ BE.unsignedInt8 1 + , BE.list (BE.jsonPair DT.pathEncoder DT.testEncoder) testChain + , deciderEncoder encoder success + , deciderEncoder encoder failure + ] + + FanOut path edges fallback -> + BE.sequence + [ BE.unsignedInt8 2 + , DT.pathEncoder path + , BE.list (BE.jsonPair DT.testEncoder (deciderEncoder encoder)) edges + , deciderEncoder encoder fallback + ] + + +deciderDecoder : BD.Decoder a -> BD.Decoder (Decider a) +deciderDecoder decoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.map Leaf decoder + + 1 -> + BD.map3 Chain + (BD.list (BD.jsonPair DT.pathDecoder DT.testDecoder)) + (deciderDecoder decoder) + (deciderDecoder decoder) + + 2 -> + BD.map3 FanOut + DT.pathDecoder + (BD.list (BD.jsonPair DT.testDecoder (deciderDecoder decoder))) + (deciderDecoder decoder) + + _ -> + BD.fail + ) + + +choiceEncoder : Choice -> BE.Encoder +choiceEncoder choice = + case choice of + Inline value -> + BE.sequence + [ BE.unsignedInt8 0 + , exprEncoder value + ] + + Jump value -> + BE.sequence + [ BE.unsignedInt8 1 + , BE.int value + ] + + +choiceDecoder : BD.Decoder Choice +choiceDecoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.map Inline exprDecoder + + 1 -> + BD.map Jump BD.int + + _ -> + BD.fail + ) + + +pathEncoder : Path -> BE.Encoder +pathEncoder path = + case path of + Index index subPath -> + BE.sequence + [ BE.unsignedInt8 0 + , Index.zeroBasedEncoder index + , pathEncoder subPath + ] + + ArrayIndex index subPath -> + BE.sequence + [ BE.unsignedInt8 1 + , BE.int index + , pathEncoder subPath + ] + + Field field subPath -> + BE.sequence + [ BE.unsignedInt8 2 + , BE.string field + , pathEncoder subPath + ] + + Unbox subPath -> + BE.sequence + [ BE.unsignedInt8 3 + , pathEncoder subPath + ] + + Root name -> + BE.sequence + [ BE.unsignedInt8 4 + , BE.string name + ] + + +pathDecoder : BD.Decoder Path +pathDecoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.map2 Index + Index.zeroBasedDecoder + pathDecoder + + 1 -> + BD.map2 ArrayIndex + BD.int + pathDecoder + + 2 -> + BD.map2 Field + BD.string + pathDecoder + + 3 -> + BD.map Unbox pathDecoder + + 4 -> + BD.map Root BD.string + + _ -> + BD.fail + ) + + +effectsTypeEncoder : EffectsType -> BE.Encoder +effectsTypeEncoder effectsType = + BE.unsignedInt8 + (case effectsType of + Cmd -> + 0 + + Sub -> + 1 + + Fx -> + 2 + ) + + +effectsTypeDecoder : BD.Decoder EffectsType +effectsTypeDecoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.succeed Cmd + + 1 -> + BD.succeed Sub + + 2 -> + BD.succeed Fx + + _ -> + BD.fail + ) diff --git a/src/Compiler/AST/Source.elm b/src/Compiler/AST/Source.elm new file mode 100644 index 0000000000..fa21d7ffed --- /dev/null +++ b/src/Compiler/AST/Source.elm @@ -0,0 +1,1575 @@ +module Compiler.AST.Source exposing + ( Alias(..) + , C0Eol + , C1 + , C1Eol + , C2 + , C2Eol + , C3 + , Comment(..) + , Def(..) + , Docs(..) + , Effects(..) + , Exposed(..) + , Exposing(..) + , Expr + , Expr_(..) + , FComment(..) + , FComments + , ForceMultiline(..) + , Import(..) + , Infix(..) + , Manager(..) + , Module(..) + , OpenCommentedList(..) + , Pair(..) + , Pattern + , Pattern_(..) + , Port(..) + , Privacy(..) + , Type + , Type_(..) + , Union(..) + , Value(..) + , VarType(..) + , c0EolDecoder + , c0EolEncoder + , c0EolMap + , c0EolValue + , c1Decoder + , c1Encoder + , c1Value + , c1map + , c2EolDecoder + , c2EolEncoder + , c2EolMap + , c2EolValue + , c2Value + , c2map + , fCommentsDecoder + , getImportName + , getName + , mapPair + , moduleDecoder + , moduleEncoder + , openCommentedListMap + , sequenceAC2 + , toCommentedList + , typeDecoder + , typeEncoder + ) + +import Compiler.AST.Utils.Binop as Binop +import Compiler.AST.Utils.Shader as Shader +import Compiler.Data.Name as Name exposing (Name) +import Compiler.Parse.Primitives as P +import Compiler.Parse.SyntaxVersion as SV exposing (SyntaxVersion) +import Compiler.Reporting.Annotation as A +import Utils.Bytes.Decode as BD +import Utils.Bytes.Encode as BE + + + +-- FORMAT + + +type ForceMultiline + = ForceMultiline Bool + + +type FComment + = BlockComment (List String) + | LineComment String + | CommentTrickOpener + | CommentTrickCloser + | CommentTrickBlock String + + +type alias FComments = + List FComment + + +type alias C1 a = + ( FComments, a ) + + +c1map : (a -> b) -> C1 a -> C1 b +c1map f ( comments, a ) = + ( comments, f a ) + + +c1Value : C1 a -> a +c1Value ( _, a ) = + a + + +type alias C2 a = + ( ( FComments, FComments ), a ) + + +c2map : (a -> b) -> C2 a -> C2 b +c2map f ( ( before, after ), a ) = + ( ( before, after ), f a ) + + +c2Value : C2 a -> a +c2Value ( _, a ) = + a + + +sequenceAC2 : List (C2 a) -> C2 (List a) +sequenceAC2 = + List.foldr + (\( ( before, after ), a ) ( ( beforeAcc, afterAcc ), acc ) -> + ( ( before ++ beforeAcc, after ++ afterAcc ), a :: acc ) + ) + ( ( [], [] ), [] ) + + +type alias C3 a = + ( ( FComments, FComments, FComments ), a ) + + +type alias C0Eol a = + ( Maybe String, a ) + + +c0EolMap : (a -> b) -> C0Eol a -> C0Eol b +c0EolMap f ( eol, a ) = + ( eol, f a ) + + +c0EolValue : C0Eol a -> a +c0EolValue ( _, a ) = + a + + +type alias C1Eol a = + ( FComments, Maybe String, a ) + + +type alias C2Eol a = + ( ( FComments, FComments, Maybe String ), a ) + + +c2EolMap : (a -> b) -> C2Eol a -> C2Eol b +c2EolMap f ( ( before, after, eol ), a ) = + ( ( before, after, eol ), f a ) + + +c2EolValue : C2Eol a -> a +c2EolValue ( _, a ) = + a + + +{-| This represents a list of things that have a clear start delimiter but no +clear end delimiter. +There must be at least one item. +Comments can appear before the last item, or around any other item. +An end-of-line comment can also appear after the last item. + +For example: += a += a, b, c + +TODO: this should be replaced with (Sequence a) + +-} +type OpenCommentedList a + = OpenCommentedList (List (C2Eol a)) (C1Eol a) + + +openCommentedListMap : (a -> b) -> OpenCommentedList a -> OpenCommentedList b +openCommentedListMap f (OpenCommentedList rest ( preLst, eolLst, lst )) = + OpenCommentedList + (List.map (\( ( pre, post, eol ), a ) -> ( ( pre, post, eol ), f a )) rest) + ( preLst, eolLst, f lst ) + + +toCommentedList : OpenCommentedList Type -> List (C2Eol Type) +toCommentedList (OpenCommentedList rest ( cLast, eolLast, last )) = + rest ++ [ ( ( cLast, [], eolLast ), last ) ] + + +{-| Represents a delimiter-separated pair. + +Comments can appear after the key or before the value. + +For example: + +key = value +key : value + +-} +type Pair key value + = Pair (C1 key) (C1 value) ForceMultiline + + +mapPair : (a1 -> a2) -> (b1 -> b2) -> Pair a1 b1 -> Pair a2 b2 +mapPair fa fb (Pair k v fm) = + Pair (c1map fa k) (c1map fb v) fm + + + +-- EXPRESSIONS + + +type alias Expr = + A.Located Expr_ + + +type Expr_ + = Chr String + | Str String Bool + | Int Int String + | Float Float String + | Var VarType Name + | VarQual VarType Name Name + | List (List (C2Eol Expr)) FComments + | Op Name + | Negate Expr + | Binops (List ( Expr, C2 (A.Located Name) )) Expr + | Lambda (C1 (List (C1 Pattern))) (C1 Expr) + | Call Expr (List (C1 Expr)) + | If (C1 ( C2 Expr, C2 Expr )) (List (C1 ( C2 Expr, C2 Expr ))) (C1 Expr) + | Let (List (C2 (A.Located Def))) FComments Expr + | Case (C2 Expr) (List ( C2 Pattern, C1 Expr )) + | Accessor Name + | Access Expr (A.Located Name) + | Update (C2 Expr) (C1 (List (C2Eol ( C1 (A.Located Name), C1 Expr )))) + | Record (C1 (List (C2Eol ( C1 (A.Located Name), C1 Expr )))) + | Unit + | Tuple (C2 Expr) (C2 Expr) (List (C2 Expr)) + | Shader Shader.Source Shader.Types + | Parens (C2 Expr) + + +type VarType + = LowVar + | CapVar + + + +-- DEFINITIONS + + +type Def + = Define (A.Located Name) (List (C1 Pattern)) (C1 Expr) (Maybe (C1 (C2 Type))) + | Destruct Pattern (C1 Expr) + + + +-- PATTERN + + +type alias Pattern = + A.Located Pattern_ + + +type Pattern_ + = PAnything Name + | PVar Name + | PRecord (C1 (List (C2 (A.Located Name)))) + | PAlias (C1 Pattern) (C1 (A.Located Name)) + | PUnit FComments + | PTuple (C2 Pattern) (C2 Pattern) (List (C2 Pattern)) + | PCtor A.Region Name (List (C1 Pattern)) + | PCtorQual A.Region Name Name (List (C1 Pattern)) + | PList (C1 (List (C2 Pattern))) + | PCons (C0Eol Pattern) (C2Eol Pattern) + | PChr String + | PStr String Bool + | PInt Int String + | PParens (C2 Pattern) + + + +-- TYPE + + +type alias Type = + A.Located Type_ + + +type Type_ + = TLambda (C0Eol Type) (C2Eol Type) + | TVar Name + | TType A.Region Name (List (C1 Type)) + | TTypeQual A.Region Name Name (List (C1 Type)) + | TRecord (List (C2 ( C1 (A.Located Name), C1 Type ))) (Maybe (C2 (A.Located Name))) FComments + | TUnit + | TTuple (C2Eol Type) (C2Eol Type) (List (C2Eol Type)) + | TParens (C2 Type) + + + +-- MODULE + + +type Module + = Module SyntaxVersion (Maybe (A.Located Name)) (A.Located Exposing) Docs (List Import) (List (A.Located Value)) (List (A.Located Union)) (List (A.Located Alias)) (List (A.Located Infix)) Effects + + +getName : Module -> Name +getName (Module _ maybeName _ _ _ _ _ _ _ _) = + case maybeName of + Just (A.At _ name) -> + name + + Nothing -> + Name.mainModule + + +getImportName : Import -> Name +getImportName (Import ( _, A.At _ name ) _ _) = + name + + +type Import + = Import (C1 (A.Located Name)) (Maybe (C2 Name)) (C2 Exposing) + + +type Value + = Value FComments (C1 (A.Located Name)) (List (C1 Pattern)) (C1 Expr) (Maybe (C1 (C2 Type))) + + +type Union + = Union (C2 (A.Located Name)) (List (C1 (A.Located Name))) (List (C2Eol ( A.Located Name, List (C1 Type) ))) + + +type Alias + = Alias FComments (C2 (A.Located Name)) (List (C1 (A.Located Name))) (C1 Type) + + +type Infix + = Infix (C2 Name) (C1 Binop.Associativity) (C1 Binop.Precedence) (C1 Name) + + +type Port + = Port FComments (C2 (A.Located Name)) Type + + +type Effects + = NoEffects + | Ports (List Port) + | Manager A.Region Manager + + +type Manager + = Cmd (C2 (C2 (A.Located Name))) + | Sub (C2 (C2 (A.Located Name))) + | Fx (C2 (C2 (A.Located Name))) (C2 (C2 (A.Located Name))) + + +type Docs + = NoDocs A.Region (List ( Name, Comment )) + | YesDocs Comment (List ( Name, Comment )) + + +type Comment + = Comment P.Snippet + + + +-- EXPOSING + + +type Exposing + = Open FComments FComments + | Explicit (A.Located (List (C2 Exposed))) + + +type Exposed + = Lower (A.Located Name) + | Upper (A.Located Name) (C1 Privacy) + | Operator A.Region Name + + +type Privacy + = Public A.Region + | Private + + + +-- ENCODERS and DECODERS + + +fCommentEncoder : FComment -> BE.Encoder +fCommentEncoder formatComment = + case formatComment of + BlockComment c -> + BE.sequence + [ BE.unsignedInt8 0 + , BE.list BE.string c + ] + + LineComment c -> + BE.sequence + [ BE.unsignedInt8 1 + , BE.string c + ] + + CommentTrickOpener -> + BE.unsignedInt8 2 + + CommentTrickCloser -> + BE.unsignedInt8 3 + + CommentTrickBlock c -> + BE.sequence + [ BE.unsignedInt8 4 + , BE.string c + ] + + +fCommentDecoder : BD.Decoder FComment +fCommentDecoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.map BlockComment (BD.list BD.string) + + 1 -> + BD.map LineComment BD.string + + 2 -> + BD.succeed CommentTrickOpener + + 3 -> + BD.succeed CommentTrickCloser + + 4 -> + BD.map CommentTrickBlock BD.string + + _ -> + BD.fail + ) + + +fCommentsEncoder : FComments -> BE.Encoder +fCommentsEncoder = + BE.list fCommentEncoder + + +fCommentsDecoder : BD.Decoder FComments +fCommentsDecoder = + BD.list fCommentDecoder + + +c0EolEncoder : (a -> BE.Encoder) -> C0Eol a -> BE.Encoder +c0EolEncoder encoder ( eol, a ) = + BE.sequence + [ BE.maybe BE.string eol + , encoder a + ] + + +c0EolDecoder : BD.Decoder a -> BD.Decoder (C0Eol a) +c0EolDecoder decoder = + BD.map2 Tuple.pair + (BD.maybe BD.string) + decoder + + +c1Encoder : (a -> BE.Encoder) -> C1 a -> BE.Encoder +c1Encoder encoder ( comments, a ) = + BE.sequence + [ fCommentsEncoder comments + , encoder a + ] + + +c1Decoder : BD.Decoder a -> BD.Decoder (C1 a) +c1Decoder decoder = + BD.map2 Tuple.pair fCommentsDecoder decoder + + +c2Encoder : (a -> BE.Encoder) -> C2 a -> BE.Encoder +c2Encoder encoder ( ( preComments, postComments ), a ) = + BE.sequence + [ fCommentsEncoder preComments + , fCommentsEncoder postComments + , encoder a + ] + + +c2Decoder : BD.Decoder a -> BD.Decoder (C2 a) +c2Decoder decoder = + BD.map3 + (\preComments postComments a -> + ( ( preComments, postComments ), a ) + ) + fCommentsDecoder + fCommentsDecoder + decoder + + +c2EolEncoder : (a -> BE.Encoder) -> C2Eol a -> BE.Encoder +c2EolEncoder encoder ( ( preComments, postComments, eol ), a ) = + BE.sequence + [ fCommentsEncoder preComments + , fCommentsEncoder postComments + , BE.maybe BE.string eol + , encoder a + ] + + +c2EolDecoder : BD.Decoder a -> BD.Decoder (C2Eol a) +c2EolDecoder decoder = + BD.map4 + (\preComments postComments eol a -> + ( ( preComments, postComments, eol ), a ) + ) + fCommentsDecoder + fCommentsDecoder + (BD.maybe BD.string) + decoder + + +typeEncoder : Type -> BE.Encoder +typeEncoder = + A.locatedEncoder internalTypeEncoder + + +typeDecoder : BD.Decoder Type +typeDecoder = + A.locatedDecoder internalTypeDecoder + + +internalTypeEncoder : Type_ -> BE.Encoder +internalTypeEncoder type_ = + case type_ of + TLambda arg result -> + BE.sequence + [ BE.unsignedInt8 0 + , c0EolEncoder typeEncoder arg + , c2EolEncoder typeEncoder result + ] + + TVar name -> + BE.sequence + [ BE.unsignedInt8 1 + , BE.string name + ] + + TType region name args -> + BE.sequence + [ BE.unsignedInt8 2 + , A.regionEncoder region + , BE.string name + , BE.list (c1Encoder typeEncoder) args + ] + + TTypeQual region home name args -> + BE.sequence + [ BE.unsignedInt8 3 + , A.regionEncoder region + , BE.string home + , BE.string name + , BE.list (c1Encoder typeEncoder) args + ] + + TRecord fields ext trailing -> + BE.sequence + [ BE.unsignedInt8 4 + , BE.list (c2Encoder (BE.jsonPair (c1Encoder (A.locatedEncoder BE.string)) (c1Encoder typeEncoder))) fields + , BE.maybe (c2Encoder (A.locatedEncoder BE.string)) ext + , fCommentsEncoder trailing + ] + + TUnit -> + BE.unsignedInt8 5 + + TTuple a b cs -> + BE.sequence + [ BE.unsignedInt8 6 + , c2EolEncoder typeEncoder a + , c2EolEncoder typeEncoder b + , BE.list (c2EolEncoder typeEncoder) cs + ] + + TParens type__ -> + BE.sequence + [ BE.unsignedInt8 7 + , c2Encoder typeEncoder type__ + ] + + +internalTypeDecoder : BD.Decoder Type_ +internalTypeDecoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.map2 TLambda + (c0EolDecoder typeDecoder) + (c2EolDecoder typeDecoder) + + 1 -> + BD.map TVar BD.string + + 2 -> + BD.map3 TType + A.regionDecoder + BD.string + (BD.list (c1Decoder typeDecoder)) + + 3 -> + BD.map4 TTypeQual + A.regionDecoder + BD.string + BD.string + (BD.list (c1Decoder typeDecoder)) + + 4 -> + BD.map3 TRecord + (BD.list (c2Decoder (BD.jsonPair (c1Decoder (A.locatedDecoder BD.string)) (c1Decoder typeDecoder)))) + (BD.maybe (c2Decoder (A.locatedDecoder BD.string))) + fCommentsDecoder + + 5 -> + BD.succeed TUnit + + 6 -> + BD.map3 TTuple + (c2EolDecoder typeDecoder) + (c2EolDecoder typeDecoder) + (BD.list (c2EolDecoder typeDecoder)) + + 7 -> + BD.map TParens + (c2Decoder typeDecoder) + + _ -> + BD.fail + ) + + +moduleEncoder : Module -> BE.Encoder +moduleEncoder (Module syntaxVersion maybeName exports docs imports values unions aliases binops effects) = + BE.sequence + [ SV.encoder syntaxVersion + , BE.maybe (A.locatedEncoder BE.string) maybeName + , A.locatedEncoder exposingEncoder exports + , docsEncoder docs + , BE.list importEncoder imports + , BE.list (A.locatedEncoder valueEncoder) values + , BE.list (A.locatedEncoder unionEncoder) unions + , BE.list (A.locatedEncoder aliasEncoder) aliases + , BE.list (A.locatedEncoder infixEncoder) binops + , effectsEncoder effects + ] + + +moduleDecoder : BD.Decoder Module +moduleDecoder = + BD.map8 (\( syntaxVersion, maybeName ) ( exports, docs ) -> Module syntaxVersion maybeName exports docs) + (BD.jsonPair SV.decoder (BD.maybe (A.locatedDecoder BD.string))) + (BD.jsonPair (A.locatedDecoder exposingDecoder) docsDecoder) + (BD.list importDecoder) + (BD.list (A.locatedDecoder valueDecoder)) + (BD.list (A.locatedDecoder unionDecoder)) + (BD.list (A.locatedDecoder aliasDecoder)) + (BD.list (A.locatedDecoder infixDecoder)) + effectsDecoder + + +exposingEncoder : Exposing -> BE.Encoder +exposingEncoder exposing_ = + case exposing_ of + Open preComments postComments -> + BE.sequence + [ BE.unsignedInt8 0 + , fCommentsEncoder preComments + , fCommentsEncoder postComments + ] + + Explicit exposedList -> + BE.sequence + [ BE.unsignedInt8 1 + , A.locatedEncoder (BE.list (c2Encoder exposedEncoder)) exposedList + ] + + +exposingDecoder : BD.Decoder Exposing +exposingDecoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.map2 Open + fCommentsDecoder + fCommentsDecoder + + 1 -> + BD.map Explicit (A.locatedDecoder (BD.list (c2Decoder exposedDecoder))) + + _ -> + BD.fail + ) + + +docsEncoder : Docs -> BE.Encoder +docsEncoder docs = + case docs of + NoDocs region comments -> + BE.sequence + [ BE.unsignedInt8 0 + , A.regionEncoder region + , BE.list (BE.jsonPair BE.string commentEncoder) comments + ] + + YesDocs overview comments -> + BE.sequence + [ BE.unsignedInt8 1 + , commentEncoder overview + , BE.list (BE.jsonPair BE.string commentEncoder) comments + ] + + +docsDecoder : BD.Decoder Docs +docsDecoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.map2 NoDocs + A.regionDecoder + (BD.list (BD.jsonPair BD.string commentDecoder)) + + 1 -> + BD.map2 YesDocs + commentDecoder + (BD.list (BD.jsonPair BD.string commentDecoder)) + + _ -> + BD.fail + ) + + +importEncoder : Import -> BE.Encoder +importEncoder (Import importName maybeAlias exposing_) = + BE.sequence + [ c1Encoder (A.locatedEncoder BE.string) importName + , BE.maybe (c2Encoder BE.string) maybeAlias + , c2Encoder exposingEncoder exposing_ + ] + + +importDecoder : BD.Decoder Import +importDecoder = + BD.map3 Import + (c1Decoder (A.locatedDecoder BD.string)) + (BD.maybe (c2Decoder BD.string)) + (c2Decoder exposingDecoder) + + +valueEncoder : Value -> BE.Encoder +valueEncoder (Value formatComments name srcArgs body maybeType) = + BE.sequence + [ fCommentsEncoder formatComments + , c1Encoder (A.locatedEncoder BE.string) name + , BE.list (c1Encoder patternEncoder) srcArgs + , c1Encoder exprEncoder body + , BE.maybe (c1Encoder (c2Encoder typeEncoder)) maybeType + ] + + +valueDecoder : BD.Decoder Value +valueDecoder = + BD.map5 Value + fCommentsDecoder + (c1Decoder (A.locatedDecoder BD.string)) + (BD.list (c1Decoder patternDecoder)) + (c1Decoder exprDecoder) + (BD.maybe (c1Decoder (c2Decoder typeDecoder))) + + +unionEncoder : Union -> BE.Encoder +unionEncoder (Union name args constructors) = + BE.sequence + [ c2Encoder (A.locatedEncoder BE.string) name + , BE.list (c1Encoder (A.locatedEncoder BE.string)) args + , BE.list (c2EolEncoder (BE.jsonPair (A.locatedEncoder BE.string) (BE.list (c1Encoder typeEncoder)))) constructors + ] + + +unionDecoder : BD.Decoder Union +unionDecoder = + BD.map3 Union + (c2Decoder (A.locatedDecoder BD.string)) + (BD.list (c1Decoder (A.locatedDecoder BD.string))) + (BD.list (c2EolDecoder (BD.jsonPair (A.locatedDecoder BD.string) (BD.list (c1Decoder typeDecoder))))) + + +aliasEncoder : Alias -> BE.Encoder +aliasEncoder (Alias formatComments name args tipe) = + BE.sequence + [ fCommentsEncoder formatComments + , c2Encoder (A.locatedEncoder BE.string) name + , BE.list (c1Encoder (A.locatedEncoder BE.string)) args + , c1Encoder typeEncoder tipe + ] + + +aliasDecoder : BD.Decoder Alias +aliasDecoder = + BD.map4 Alias + fCommentsDecoder + (c2Decoder (A.locatedDecoder BD.string)) + (BD.list (c1Decoder (A.locatedDecoder BD.string))) + (c1Decoder typeDecoder) + + +infixEncoder : Infix -> BE.Encoder +infixEncoder (Infix op associativity precedence name) = + BE.sequence + [ c2Encoder BE.string op + , c1Encoder Binop.associativityEncoder associativity + , c1Encoder Binop.precedenceEncoder precedence + , c1Encoder BE.string name + ] + + +infixDecoder : BD.Decoder Infix +infixDecoder = + BD.map4 Infix + (c2Decoder BD.string) + (c1Decoder Binop.associativityDecoder) + (c1Decoder Binop.precedenceDecoder) + (c1Decoder BD.string) + + +effectsEncoder : Effects -> BE.Encoder +effectsEncoder effects = + case effects of + NoEffects -> + BE.unsignedInt8 0 + + Ports ports -> + BE.sequence + [ BE.unsignedInt8 1 + , BE.list portEncoder ports + ] + + Manager region manager -> + BE.sequence + [ BE.unsignedInt8 2 + , A.regionEncoder region + , managerEncoder manager + ] + + +effectsDecoder : BD.Decoder Effects +effectsDecoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.succeed NoEffects + + 1 -> + BD.map Ports (BD.list portDecoder) + + 2 -> + BD.map2 Manager + A.regionDecoder + managerDecoder + + _ -> + BD.fail + ) + + +commentEncoder : Comment -> BE.Encoder +commentEncoder (Comment snippet) = + P.snippetEncoder snippet + + +commentDecoder : BD.Decoder Comment +commentDecoder = + BD.map Comment P.snippetDecoder + + +portEncoder : Port -> BE.Encoder +portEncoder (Port typeComments name tipe) = + BE.sequence + [ fCommentsEncoder typeComments + , c2Encoder (A.locatedEncoder BE.string) name + , typeEncoder tipe + ] + + +portDecoder : BD.Decoder Port +portDecoder = + BD.map3 Port + fCommentsDecoder + (c2Decoder (A.locatedDecoder BD.string)) + typeDecoder + + +managerEncoder : Manager -> BE.Encoder +managerEncoder manager = + case manager of + Cmd cmdType -> + BE.sequence + [ BE.unsignedInt8 0 + , c2Encoder (c2Encoder (A.locatedEncoder BE.string)) cmdType + ] + + Sub subType -> + BE.sequence + [ BE.unsignedInt8 1 + , c2Encoder (c2Encoder (A.locatedEncoder BE.string)) subType + ] + + Fx cmdType subType -> + BE.sequence + [ BE.unsignedInt8 2 + , c2Encoder (c2Encoder (A.locatedEncoder BE.string)) cmdType + , c2Encoder (c2Encoder (A.locatedEncoder BE.string)) subType + ] + + +managerDecoder : BD.Decoder Manager +managerDecoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.map Cmd (c2Decoder (c2Decoder (A.locatedDecoder BD.string))) + + 1 -> + BD.map Sub (c2Decoder (c2Decoder (A.locatedDecoder BD.string))) + + 2 -> + BD.map2 Fx + (c2Decoder (c2Decoder (A.locatedDecoder BD.string))) + (c2Decoder (c2Decoder (A.locatedDecoder BD.string))) + + _ -> + BD.fail + ) + + +exposedEncoder : Exposed -> BE.Encoder +exposedEncoder exposed = + case exposed of + Lower name -> + BE.sequence + [ BE.unsignedInt8 0 + , A.locatedEncoder BE.string name + ] + + Upper name dotDotRegion -> + BE.sequence + [ BE.unsignedInt8 1 + , A.locatedEncoder BE.string name + , c1Encoder privacyEncoder dotDotRegion + ] + + Operator region name -> + BE.sequence + [ BE.unsignedInt8 2 + , A.regionEncoder region + , BE.string name + ] + + +exposedDecoder : BD.Decoder Exposed +exposedDecoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.map Lower (A.locatedDecoder BD.string) + + 1 -> + BD.map2 Upper + (A.locatedDecoder BD.string) + (c1Decoder privacyDecoder) + + 2 -> + BD.map2 Operator + A.regionDecoder + BD.string + + _ -> + BD.fail + ) + + +privacyEncoder : Privacy -> BE.Encoder +privacyEncoder privacy = + case privacy of + Public region -> + BE.sequence + [ BE.unsignedInt8 0 + , A.regionEncoder region + ] + + Private -> + BE.unsignedInt8 1 + + +privacyDecoder : BD.Decoder Privacy +privacyDecoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.map Public A.regionDecoder + + 1 -> + BD.succeed Private + + _ -> + BD.fail + ) + + +patternEncoder : Pattern -> BE.Encoder +patternEncoder = + A.locatedEncoder pattern_Encoder + + +patternDecoder : BD.Decoder Pattern +patternDecoder = + A.locatedDecoder pattern_Decoder + + +pattern_Encoder : Pattern_ -> BE.Encoder +pattern_Encoder pattern_ = + case pattern_ of + PAnything name -> + BE.sequence + [ BE.unsignedInt8 0 + , BE.string name + ] + + PVar name -> + BE.sequence + [ BE.unsignedInt8 1 + , BE.string name + ] + + PRecord fields -> + BE.sequence + [ BE.unsignedInt8 2 + , c1Encoder (BE.list (c2Encoder (A.locatedEncoder BE.string))) fields + ] + + PAlias aliasPattern name -> + BE.sequence + [ BE.unsignedInt8 3 + , c1Encoder patternEncoder aliasPattern + , c1Encoder (A.locatedEncoder BE.string) name + ] + + PUnit comments -> + BE.sequence + [ BE.unsignedInt8 4 + , fCommentsEncoder comments + ] + + PTuple a b cs -> + BE.sequence + [ BE.unsignedInt8 5 + , c2Encoder patternEncoder a + , c2Encoder patternEncoder b + , BE.list (c2Encoder patternEncoder) cs + ] + + PCtor nameRegion name patterns -> + BE.sequence + [ BE.unsignedInt8 6 + , A.regionEncoder nameRegion + , BE.string name + , BE.list (c1Encoder patternEncoder) patterns + ] + + PCtorQual nameRegion home name patterns -> + BE.sequence + [ BE.unsignedInt8 7 + , A.regionEncoder nameRegion + , BE.string home + , BE.string name + , BE.list (c1Encoder patternEncoder) patterns + ] + + PList patterns -> + BE.sequence + [ BE.unsignedInt8 8 + , c1Encoder (BE.list (c2Encoder patternEncoder)) patterns + ] + + PCons hd tl -> + BE.sequence + [ BE.unsignedInt8 9 + , c0EolEncoder patternEncoder hd + , c2EolEncoder patternEncoder tl + ] + + PChr chr -> + BE.sequence + [ BE.unsignedInt8 10 + , BE.string chr + ] + + PStr str multiline -> + BE.sequence + [ BE.unsignedInt8 11 + , BE.string str + , BE.bool multiline + ] + + PInt int src -> + BE.sequence + [ BE.unsignedInt8 12 + , BE.int int + , BE.string src + ] + + PParens pattern -> + BE.sequence + [ BE.unsignedInt8 13 + , c2Encoder patternEncoder pattern + ] + + +pattern_Decoder : BD.Decoder Pattern_ +pattern_Decoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.map PAnything BD.string + + 1 -> + BD.map PVar BD.string + + 2 -> + BD.map PRecord (c1Decoder (BD.list (c2Decoder (A.locatedDecoder BD.string)))) + + 3 -> + BD.map2 PAlias + (c1Decoder patternDecoder) + (c1Decoder (A.locatedDecoder BD.string)) + + 4 -> + BD.map PUnit fCommentsDecoder + + 5 -> + BD.map3 PTuple + (c2Decoder patternDecoder) + (c2Decoder patternDecoder) + (BD.list (c2Decoder patternDecoder)) + + 6 -> + BD.map3 PCtor + A.regionDecoder + BD.string + (BD.list (c1Decoder patternDecoder)) + + 7 -> + BD.map4 PCtorQual + A.regionDecoder + BD.string + BD.string + (BD.list (c1Decoder patternDecoder)) + + 8 -> + BD.map PList (c1Decoder (BD.list (c2Decoder patternDecoder))) + + 9 -> + BD.map2 PCons + (c0EolDecoder patternDecoder) + (c2EolDecoder patternDecoder) + + 10 -> + BD.map PChr BD.string + + 11 -> + BD.map2 PStr + BD.string + BD.bool + + 12 -> + BD.map2 PInt + BD.int + BD.string + + 13 -> + BD.map PParens (c2Decoder patternDecoder) + + _ -> + BD.fail + ) + + +exprEncoder : Expr -> BE.Encoder +exprEncoder = + A.locatedEncoder expr_Encoder + + +exprDecoder : BD.Decoder Expr +exprDecoder = + A.locatedDecoder expr_Decoder + + +expr_Encoder : Expr_ -> BE.Encoder +expr_Encoder expr_ = + case expr_ of + Chr char -> + BE.sequence + [ BE.unsignedInt8 0 + , BE.string char + ] + + Str string multiline -> + BE.sequence + [ BE.unsignedInt8 1 + , BE.string string + , BE.bool multiline + ] + + Int int src -> + BE.sequence + [ BE.unsignedInt8 2 + , BE.int int + , BE.string src + ] + + Float float src -> + BE.sequence + [ BE.unsignedInt8 3 + , BE.float float + , BE.string src + ] + + Var varType name -> + BE.sequence + [ BE.unsignedInt8 4 + , varTypeEncoder varType + , BE.string name + ] + + VarQual varType prefix name -> + BE.sequence + [ BE.unsignedInt8 5 + , varTypeEncoder varType + , BE.string prefix + , BE.string name + ] + + List list trailing -> + BE.sequence + [ BE.unsignedInt8 6 + , BE.list (c2EolEncoder exprEncoder) list + , fCommentsEncoder trailing + ] + + Op op -> + BE.sequence + [ BE.unsignedInt8 7 + , BE.string op + ] + + Negate expr -> + BE.sequence + [ BE.unsignedInt8 8 + , exprEncoder expr + ] + + Binops ops final -> + BE.sequence + [ BE.unsignedInt8 9 + , BE.list (BE.jsonPair exprEncoder (c2Encoder (A.locatedEncoder BE.string))) ops + , exprEncoder final + ] + + Lambda srcArgs body -> + BE.sequence + [ BE.unsignedInt8 10 + , c1Encoder (BE.list (c1Encoder patternEncoder)) srcArgs + , c1Encoder exprEncoder body + ] + + Call func args -> + BE.sequence + [ BE.unsignedInt8 11 + , exprEncoder func + , BE.list (c1Encoder exprEncoder) args + ] + + If firstBranch branches finally -> + BE.sequence + [ BE.unsignedInt8 12 + , c1Encoder (BE.jsonPair (c2Encoder exprEncoder) (c2Encoder exprEncoder)) firstBranch + , BE.list (c1Encoder (BE.jsonPair (c2Encoder exprEncoder) (c2Encoder exprEncoder))) branches + , c1Encoder exprEncoder finally + ] + + Let defs comments expr -> + BE.sequence + [ BE.unsignedInt8 13 + , BE.list (c2Encoder (A.locatedEncoder defEncoder)) defs + , fCommentsEncoder comments + , exprEncoder expr + ] + + Case expr branches -> + BE.sequence + [ BE.unsignedInt8 14 + , c2Encoder exprEncoder expr + , BE.list (BE.jsonPair (c2Encoder patternEncoder) (c1Encoder exprEncoder)) branches + ] + + Accessor field -> + BE.sequence + [ BE.unsignedInt8 15 + , BE.string field + ] + + Access record field -> + BE.sequence + [ BE.unsignedInt8 16 + , exprEncoder record + , A.locatedEncoder BE.string field + ] + + Update name fields -> + BE.sequence + [ BE.unsignedInt8 17 + , c2Encoder exprEncoder name + , c1Encoder (BE.list (c2EolEncoder (BE.jsonPair (c1Encoder (A.locatedEncoder BE.string)) (c1Encoder exprEncoder)))) fields + ] + + Record fields -> + BE.sequence + [ BE.unsignedInt8 18 + , c1Encoder (BE.list (c2EolEncoder (BE.jsonPair (c1Encoder (A.locatedEncoder BE.string)) (c1Encoder exprEncoder)))) fields + ] + + Unit -> + BE.unsignedInt8 19 + + Tuple a b cs -> + BE.sequence + [ BE.unsignedInt8 20 + , c2Encoder exprEncoder a + , c2Encoder exprEncoder b + , BE.list (c2Encoder exprEncoder) cs + ] + + Shader src tipe -> + BE.sequence + [ BE.unsignedInt8 21 + , Shader.sourceEncoder src + , Shader.typesEncoder tipe + ] + + Parens expr -> + BE.sequence + [ BE.unsignedInt8 22 + , c2Encoder exprEncoder expr + ] + + +expr_Decoder : BD.Decoder Expr_ +expr_Decoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.map Chr BD.string + + 1 -> + BD.map2 Str + BD.string + BD.bool + + 2 -> + BD.map2 Int + BD.int + BD.string + + 3 -> + BD.map2 Float + BD.float + BD.string + + 4 -> + BD.map2 Var + varTypeDecoder + BD.string + + 5 -> + BD.map3 VarQual + varTypeDecoder + BD.string + BD.string + + 6 -> + BD.map2 List + (BD.list (c2EolDecoder exprDecoder)) + fCommentsDecoder + + 7 -> + BD.map Op BD.string + + 8 -> + BD.map Negate exprDecoder + + 9 -> + BD.map2 Binops + (BD.list (BD.jsonPair exprDecoder (c2Decoder (A.locatedDecoder BD.string)))) + exprDecoder + + 10 -> + BD.map2 Lambda + (c1Decoder (BD.list (c1Decoder patternDecoder))) + (c1Decoder exprDecoder) + + 11 -> + BD.map2 Call + exprDecoder + (BD.list (c1Decoder exprDecoder)) + + 12 -> + BD.map3 If + (c1Decoder (BD.jsonPair (c2Decoder exprDecoder) (c2Decoder exprDecoder))) + (BD.list (c1Decoder (BD.jsonPair (c2Decoder exprDecoder) (c2Decoder exprDecoder)))) + (c1Decoder exprDecoder) + + 13 -> + BD.map3 Let + (BD.list (c2Decoder (A.locatedDecoder defDecoder))) + fCommentsDecoder + exprDecoder + + 14 -> + BD.map2 Case + (c2Decoder exprDecoder) + (BD.list (BD.jsonPair (c2Decoder patternDecoder) (c1Decoder exprDecoder))) + + 15 -> + BD.map Accessor BD.string + + 16 -> + BD.map2 Access + exprDecoder + (A.locatedDecoder BD.string) + + 17 -> + BD.map2 Update + (c2Decoder exprDecoder) + (c1Decoder (BD.list (c2EolDecoder (BD.jsonPair (c1Decoder (A.locatedDecoder BD.string)) (c1Decoder exprDecoder))))) + + 18 -> + BD.map Record + (c1Decoder (BD.list (c2EolDecoder (BD.jsonPair (c1Decoder (A.locatedDecoder BD.string)) (c1Decoder exprDecoder))))) + + 19 -> + BD.succeed Unit + + 20 -> + BD.map3 Tuple + (c2Decoder exprDecoder) + (c2Decoder exprDecoder) + (BD.list (c2Decoder exprDecoder)) + + 21 -> + BD.map2 Shader + Shader.sourceDecoder + Shader.typesDecoder + + 22 -> + BD.map Parens (c2Decoder exprDecoder) + + _ -> + BD.fail + ) + + +varTypeEncoder : VarType -> BE.Encoder +varTypeEncoder varType = + BE.unsignedInt8 + (case varType of + LowVar -> + 0 + + CapVar -> + 1 + ) + + +varTypeDecoder : BD.Decoder VarType +varTypeDecoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.succeed LowVar + + 1 -> + BD.succeed CapVar + + _ -> + BD.fail + ) + + +defEncoder : Def -> BE.Encoder +defEncoder def = + case def of + Define name srcArgs body maybeType -> + BE.sequence + [ BE.unsignedInt8 0 + , A.locatedEncoder BE.string name + , BE.list (c1Encoder patternEncoder) srcArgs + , c1Encoder exprEncoder body + , BE.maybe (c1Encoder (c2Encoder typeEncoder)) maybeType + ] + + Destruct pattern body -> + BE.sequence + [ BE.unsignedInt8 1 + , patternEncoder pattern + , c1Encoder exprEncoder body + ] + + +defDecoder : BD.Decoder Def +defDecoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.map4 Define + (A.locatedDecoder BD.string) + (BD.list (c1Decoder patternDecoder)) + (c1Decoder exprDecoder) + (BD.maybe (c1Decoder (c2Decoder typeDecoder))) + + 1 -> + BD.map2 Destruct + patternDecoder + (c1Decoder exprDecoder) + + _ -> + BD.fail + ) diff --git a/src/Compiler/AST/Utils/Binop.elm b/src/Compiler/AST/Utils/Binop.elm new file mode 100644 index 0000000000..84e703c7ef --- /dev/null +++ b/src/Compiler/AST/Utils/Binop.elm @@ -0,0 +1,127 @@ +module Compiler.AST.Utils.Binop exposing + ( Associativity(..) + , Precedence + , associativityDecoder + , associativityEncoder + , jsonAssociativityDecoder + , jsonAssociativityEncoder + , jsonPrecedenceDecoder + , jsonPrecedenceEncoder + , precedenceDecoder + , precedenceEncoder + ) + +import Json.Decode as Decode +import Json.Encode as Encode +import Utils.Bytes.Decode as BD +import Utils.Bytes.Encode as BE + + + +-- BINOP STUFF + + +type alias Precedence = + Int + + +type Associativity + = Left + | Non + | Right + + + +-- JSON ENCODERS and DECODERS + + +jsonPrecedenceEncoder : Precedence -> Encode.Value +jsonPrecedenceEncoder = + Encode.int + + +jsonPrecedenceDecoder : Decode.Decoder Precedence +jsonPrecedenceDecoder = + Decode.int + + +jsonAssociativityEncoder : Associativity -> Encode.Value +jsonAssociativityEncoder associativity = + case associativity of + Left -> + Encode.string "Left" + + Non -> + Encode.string "Non" + + Right -> + Encode.string "Right" + + +jsonAssociativityDecoder : Decode.Decoder Associativity +jsonAssociativityDecoder = + Decode.string + |> Decode.andThen + (\str -> + case str of + "Left" -> + Decode.succeed Left + + "Non" -> + Decode.succeed Non + + "Right" -> + Decode.succeed Right + + _ -> + Decode.fail ("Unknown Associativity: " ++ str) + ) + + + +-- ENCODERS and DECODERS + + +precedenceEncoder : Precedence -> BE.Encoder +precedenceEncoder = + BE.int + + +precedenceDecoder : BD.Decoder Precedence +precedenceDecoder = + BD.int + + +associativityEncoder : Associativity -> BE.Encoder +associativityEncoder associativity = + BE.unsignedInt8 + (case associativity of + Left -> + 0 + + Non -> + 1 + + Right -> + 2 + ) + + +associativityDecoder : BD.Decoder Associativity +associativityDecoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.succeed Left + + 1 -> + BD.succeed Non + + 2 -> + BD.succeed Right + + _ -> + BD.fail + ) diff --git a/src/Compiler/AST/Utils/Shader.elm b/src/Compiler/AST/Utils/Shader.elm new file mode 100644 index 0000000000..24fed415e9 --- /dev/null +++ b/src/Compiler/AST/Utils/Shader.elm @@ -0,0 +1,218 @@ +module Compiler.AST.Utils.Shader exposing + ( Source(..) + , Type(..) + , Types(..) + , fromString + , sourceDecoder + , sourceEncoder + , toJsStringBuilder + , typesDecoder + , typesEncoder + , unescape + ) + +import Compiler.Data.Name exposing (Name) +import Data.Map exposing (Dict) +import Regex +import Utils.Bytes.Decode as BD +import Utils.Bytes.Encode as BE + + + +-- SOURCE + + +type Source + = Source String + + + +-- TYPES + + +type Types + = Types (Dict String Name Type) (Dict String Name Type) (Dict String Name Type) + + +type Type + = Int + | Float + | V2 + | V3 + | V4 + | M4 + | Texture + | Bool + + + +-- TO BUILDER + + +toJsStringBuilder : Source -> String +toJsStringBuilder (Source src) = + src + + + +-- FROM STRING + + +fromString : String -> Source +fromString = + Source << escape + + +escape : String -> String +escape = + String.foldr + (\char acc -> + case char of + '\u{000D}' -> + acc + + '\n' -> + acc + |> String.cons 'n' + |> String.cons '\\' + + '"' -> + acc + |> String.cons '"' + |> String.cons '\\' + + '\'' -> + acc + |> String.cons '\'' + |> String.cons '\\' + + '\\' -> + acc + |> String.cons '\\' + |> String.cons '\\' + + _ -> + String.cons char acc + ) + "" + + +unescape : String -> String +unescape = + Regex.replace + (Regex.fromString "\\\\n|\\\\\"|\\\\'|\\\\\\\\" + |> Maybe.withDefault Regex.never + ) + (\{ match } -> + case match of + "\\n" -> + "\n" + + "\\\"" -> + "\"" + + "\\'" -> + "'" + + "\\\\" -> + "\\" + + _ -> + match + ) + + + +-- ENCODERS and DECODERS + + +sourceEncoder : Source -> BE.Encoder +sourceEncoder (Source src) = + BE.string src + + +sourceDecoder : BD.Decoder Source +sourceDecoder = + BD.map Source BD.string + + +typesEncoder : Types -> BE.Encoder +typesEncoder (Types attribute uniform varying) = + BE.sequence + [ BE.assocListDict compare BE.string typeEncoder attribute + , BE.assocListDict compare BE.string typeEncoder uniform + , BE.assocListDict compare BE.string typeEncoder varying + ] + + +typesDecoder : BD.Decoder Types +typesDecoder = + BD.map3 Types + (BD.assocListDict identity BD.string typeDecoder) + (BD.assocListDict identity BD.string typeDecoder) + (BD.assocListDict identity BD.string typeDecoder) + + +typeEncoder : Type -> BE.Encoder +typeEncoder type_ = + BE.unsignedInt8 + (case type_ of + Int -> + 0 + + Float -> + 1 + + V2 -> + 2 + + V3 -> + 3 + + V4 -> + 4 + + M4 -> + 5 + + Texture -> + 6 + + Bool -> + 7 + ) + + +typeDecoder : BD.Decoder Type +typeDecoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.succeed Int + + 1 -> + BD.succeed Float + + 2 -> + BD.succeed V2 + + 3 -> + BD.succeed V3 + + 4 -> + BD.succeed V4 + + 5 -> + BD.succeed M4 + + 6 -> + BD.succeed Texture + + 7 -> + BD.succeed Bool + + _ -> + BD.fail + ) diff --git a/src/Compiler/AST/Utils/Type.elm b/src/Compiler/AST/Utils/Type.elm new file mode 100644 index 0000000000..4c155dc8e1 --- /dev/null +++ b/src/Compiler/AST/Utils/Type.elm @@ -0,0 +1,122 @@ +module Compiler.AST.Utils.Type exposing + ( dealias + , deepDealias + , delambda + , iteratedDealias + ) + +import Compiler.AST.Canonical exposing (AliasType(..), FieldType(..), Type(..)) +import Compiler.Data.Name exposing (Name) +import Data.Map as Dict exposing (Dict) + + + +-- DELAMBDA + + +delambda : Type -> List Type +delambda tipe = + case tipe of + TLambda arg result -> + arg :: delambda result + + _ -> + [ tipe ] + + + +-- DEALIAS + + +dealias : List ( Name, Type ) -> AliasType -> Type +dealias args aliasType = + case aliasType of + Holey tipe -> + dealiasHelp (Dict.fromList identity args) tipe + + Filled tipe -> + tipe + + +dealiasHelp : Dict String Name Type -> Type -> Type +dealiasHelp typeTable tipe = + case tipe of + TLambda a b -> + TLambda + (dealiasHelp typeTable a) + (dealiasHelp typeTable b) + + TVar x -> + Dict.get identity x typeTable + |> Maybe.withDefault tipe + + TRecord fields ext -> + TRecord (Dict.map (\_ -> dealiasField typeTable) fields) ext + + TAlias home name args t_ -> + TAlias home name (List.map (Tuple.mapSecond (dealiasHelp typeTable)) args) t_ + + TType home name args -> + TType home name (List.map (dealiasHelp typeTable) args) + + TUnit -> + TUnit + + TTuple a b cs -> + TTuple + (dealiasHelp typeTable a) + (dealiasHelp typeTable b) + (List.map (dealiasHelp typeTable) cs) + + +dealiasField : Dict String Name Type -> FieldType -> FieldType +dealiasField typeTable (FieldType index tipe) = + FieldType index (dealiasHelp typeTable tipe) + + + +-- DEEP DEALIAS + + +deepDealias : Type -> Type +deepDealias tipe = + case tipe of + TLambda a b -> + TLambda (deepDealias a) (deepDealias b) + + TVar _ -> + tipe + + TRecord fields ext -> + TRecord (Dict.map (\_ -> deepDealiasField) fields) ext + + TAlias _ _ args tipe_ -> + deepDealias (dealias args tipe_) + + TType home name args -> + TType home name (List.map deepDealias args) + + TUnit -> + TUnit + + TTuple a b cs -> + TTuple (deepDealias a) (deepDealias b) (List.map deepDealias cs) + + +deepDealiasField : FieldType -> FieldType +deepDealiasField (FieldType index tipe) = + FieldType index (deepDealias tipe) + + + +-- ITERATED DEALIAS + + +iteratedDealias : Type -> Type +iteratedDealias tipe = + case tipe of + TAlias _ _ args realType -> + iteratedDealias (dealias args realType) + + _ -> + tipe diff --git a/src/Compiler/Canonicalize/Effects.elm b/src/Compiler/Canonicalize/Effects.elm new file mode 100644 index 0000000000..547ea36ce4 --- /dev/null +++ b/src/Compiler/Canonicalize/Effects.elm @@ -0,0 +1,308 @@ +module Compiler.Canonicalize.Effects exposing + ( canonicalize + , checkPayload + ) + +import Compiler.AST.Canonical as Can +import Compiler.AST.Source as Src +import Compiler.AST.Utils.Type as Type +import Compiler.Canonicalize.Environment as Env +import Compiler.Canonicalize.Type as Type +import Compiler.Data.Name as Name +import Compiler.Elm.ModuleName as ModuleName +import Compiler.Parse.SyntaxVersion exposing (SyntaxVersion) +import Compiler.Reporting.Annotation as A +import Compiler.Reporting.Error.Canonicalize as Error +import Compiler.Reporting.Result as R +import Data.Map as Dict exposing (Dict) +import Maybe exposing (Maybe(..)) +import System.TypeCheck.IO as IO + + + +-- RESULT + + +type alias EResult i w a = + R.RResult i w Error.Error a + + + +-- CANONICALIZE + + +canonicalize : + SyntaxVersion + -> Env.Env + -> List (A.Located Src.Value) + -> Dict String Name.Name union + -> Src.Effects + -> EResult i w Can.Effects +canonicalize syntaxVersion env values unions effects = + case effects of + Src.NoEffects -> + R.ok Can.NoEffects + + Src.Ports ports -> + R.traverse (canonicalizePort syntaxVersion env) ports + |> R.fmap (Can.Ports << Dict.fromList identity) + + Src.Manager region manager -> + let + dict : Dict String Name.Name A.Region + dict = + Dict.fromList identity (List.map toNameRegion values) + in + R.fmap Can.Manager (verifyManager region dict "init") + |> R.apply (verifyManager region dict "onEffects") + |> R.apply (verifyManager region dict "onSelfMsg") + |> R.apply + (case manager of + Src.Cmd ( _, ( _, cmdType ) ) -> + R.fmap Can.Cmd (verifyEffectType cmdType unions) + |> R.bind + (\result -> + verifyManager region dict "cmdMap" + |> R.fmap (\_ -> result) + ) + + Src.Sub ( _, ( _, subType ) ) -> + R.fmap Can.Sub (verifyEffectType subType unions) + |> R.bind + (\result -> + verifyManager region dict "subMap" + |> R.fmap (\_ -> result) + ) + + Src.Fx ( _, ( _, cmdType ) ) ( _, ( _, subType ) ) -> + R.fmap Can.Fx (verifyEffectType cmdType unions) + |> R.apply (verifyEffectType subType unions) + |> R.bind + (\result -> + verifyManager region dict "cmdMap" + |> R.fmap (\_ -> result) + ) + |> R.bind + (\result -> + verifyManager region dict "subMap" + |> R.fmap (\_ -> result) + ) + ) + + + +-- CANONICALIZE PORT + + +canonicalizePort : SyntaxVersion -> Env.Env -> Src.Port -> EResult i w ( Name.Name, Can.Port ) +canonicalizePort syntaxVersion env (Src.Port _ ( _, A.At region portName ) tipe) = + Type.toAnnotation syntaxVersion env tipe + |> R.bind + (\(Can.Forall freeVars ctipe) -> + case List.reverse (Type.delambda (Type.deepDealias ctipe)) of + (Can.TType home name [ msg ]) :: revArgs -> + if home == ModuleName.cmd && name == Name.cmd then + case revArgs of + [] -> + R.throw (Error.PortTypeInvalid region portName Error.CmdNoArg) + + [ outgoingType ] -> + case msg of + Can.TVar _ -> + case checkPayload outgoingType of + Ok () -> + R.ok + ( portName + , Can.Outgoing + { freeVars = freeVars + , payload = outgoingType + , func = ctipe + } + ) + + Err ( badType, err ) -> + R.throw (Error.PortPayloadInvalid region portName badType err) + + _ -> + R.throw (Error.PortTypeInvalid region portName Error.CmdBadMsg) + + _ -> + R.throw (Error.PortTypeInvalid region portName (Error.CmdExtraArgs (List.length revArgs))) + + else if home == ModuleName.sub && name == Name.sub then + case revArgs of + [ Can.TLambda incomingType (Can.TVar msg1) ] -> + case msg of + Can.TVar msg2 -> + if msg1 == msg2 then + case checkPayload incomingType of + Ok () -> + R.ok + ( portName + , Can.Incoming + { freeVars = freeVars + , payload = incomingType + , func = ctipe + } + ) + + Err ( badType, err ) -> + R.throw (Error.PortPayloadInvalid region portName badType err) + + else + R.throw (Error.PortTypeInvalid region portName Error.SubBad) + + _ -> + R.throw (Error.PortTypeInvalid region portName Error.SubBad) + + _ -> + R.throw (Error.PortTypeInvalid region portName Error.SubBad) + + else + R.throw (Error.PortTypeInvalid region portName Error.NotCmdOrSub) + + _ -> + R.throw (Error.PortTypeInvalid region portName Error.NotCmdOrSub) + ) + + + +-- VERIFY MANAGER + + +verifyEffectType : A.Located Name.Name -> Dict String Name.Name a -> EResult i w Name.Name +verifyEffectType (A.At region name) unions = + if Dict.member identity name unions then + R.ok name + + else + R.throw (Error.EffectNotFound region name) + + +toNameRegion : A.Located Src.Value -> ( Name.Name, A.Region ) +toNameRegion (A.At _ (Src.Value _ ( _, A.At region name ) _ _ _)) = + ( name, region ) + + +verifyManager : A.Region -> Dict String Name.Name A.Region -> Name.Name -> EResult i w A.Region +verifyManager tagRegion values name = + case Dict.get identity name values of + Just region -> + R.ok region + + Nothing -> + R.throw (Error.EffectFunctionNotFound tagRegion name) + + + +-- CHECK PAYLOAD TYPES + + +checkPayload : Can.Type -> Result ( Can.Type, Error.InvalidPayload ) () +checkPayload tipe = + case tipe of + Can.TAlias _ _ args aliasedType -> + checkPayload (Type.dealias args aliasedType) + + Can.TType home name args -> + case args of + [] -> + if isJson home name || isString home name || isIntFloatBool home name then + Ok () + + else + Err ( tipe, Error.UnsupportedType name ) + + [ arg ] -> + if isList home name || isMaybe home name || isArray home name then + checkPayload arg + + else + Err ( tipe, Error.UnsupportedType name ) + + _ -> + Err ( tipe, Error.UnsupportedType name ) + + Can.TUnit -> + Ok () + + Can.TTuple a b cs -> + checkPayload a + |> Result.andThen (\_ -> checkPayload b) + |> Result.andThen (\_ -> checkPayloadTupleCs cs) + + Can.TVar name -> + Err ( tipe, Error.TypeVariable name ) + + Can.TLambda _ _ -> + Err ( tipe, Error.Function ) + + Can.TRecord _ (Just _) -> + Err ( tipe, Error.ExtendedRecord ) + + Can.TRecord fields Nothing -> + Dict.foldl compare + (\_ field acc -> Result.andThen (\_ -> checkFieldPayload field) acc) + (Ok ()) + fields + + +checkPayloadTupleCs : List Can.Type -> Result ( Can.Type, Error.InvalidPayload ) () +checkPayloadTupleCs types = + case types of + [] -> + Ok () + + tipe :: rest -> + checkPayload tipe + |> Result.andThen (\_ -> checkPayloadTupleCs rest) + + +checkFieldPayload : Can.FieldType -> Result ( Can.Type, Error.InvalidPayload ) () +checkFieldPayload (Can.FieldType _ tipe) = + checkPayload tipe + + +isIntFloatBool : IO.Canonical -> Name.Name -> Bool +isIntFloatBool home name = + home + == ModuleName.basics + && (name == Name.int || name == Name.float || name == Name.bool) + + +isString : IO.Canonical -> Name.Name -> Bool +isString home name = + home + == ModuleName.string + && name + == Name.string + + +isJson : IO.Canonical -> Name.Name -> Bool +isJson home name = + (home == ModuleName.jsonEncode) + && (name == Name.value) + + +isList : IO.Canonical -> Name.Name -> Bool +isList home name = + home + == ModuleName.list + && name + == Name.list + + +isMaybe : IO.Canonical -> Name.Name -> Bool +isMaybe home name = + home + == ModuleName.maybe + && name + == Name.maybe + + +isArray : IO.Canonical -> Name.Name -> Bool +isArray home name = + home + == ModuleName.array + && name + == Name.array diff --git a/src/Compiler/Canonicalize/Environment.elm b/src/Compiler/Canonicalize/Environment.elm new file mode 100644 index 0000000000..fab735f805 --- /dev/null +++ b/src/Compiler/Canonicalize/Environment.elm @@ -0,0 +1,270 @@ +module Compiler.Canonicalize.Environment exposing + ( Binop(..) + , Ctor(..) + , EResult + , Env + , Exposed + , Info(..) + , Qualified + , Type(..) + , Var(..) + , addLocals + , findBinop + , findCtor + , findCtorQual + , findType + , findTypeQual + , mergeInfo + ) + +import Compiler.AST.Canonical as Can +import Compiler.AST.Utils.Binop as Binop +import Compiler.Data.Index as Index +import Compiler.Data.Name as Name +import Compiler.Data.OneOrMore as OneOrMore +import Compiler.Reporting.Annotation as A +import Compiler.Reporting.Error.Canonicalize as Error +import Compiler.Reporting.Result as R +import Data.Map as Dict exposing (Dict) +import Data.Set as EverySet +import Maybe exposing (Maybe(..)) +import System.TypeCheck.IO exposing (Canonical) + + + +-- RESULT + + +type alias EResult i w a = + R.RResult i w Error.Error a + + + +-- ENVIRONMENT + + +type alias Env = + { home : Canonical + , vars : Dict String Name.Name Var + , types : Exposed Type + , ctors : Exposed Ctor + , binops : Exposed Binop + , q_vars : Qualified Can.Annotation + , q_types : Qualified Type + , q_ctors : Qualified Ctor + } + + +type alias Exposed a = + Dict String Name.Name (Info a) + + +type alias Qualified a = + Dict String Name.Name (Dict String Name.Name (Info a)) + + + +-- INFO + + +type Info a + = Specific Canonical a + | Ambiguous Canonical (OneOrMore.OneOrMore Canonical) + + +mergeInfo : Info a -> Info a -> Info a +mergeInfo info1 info2 = + case info1 of + Specific h1 _ -> + case info2 of + Specific h2 _ -> + if h1 == h2 then + info1 + + else + Ambiguous h1 (OneOrMore.one h2) + + Ambiguous h2 hs2 -> + Ambiguous h1 (OneOrMore.more (OneOrMore.one h2) hs2) + + Ambiguous h1 hs1 -> + case info2 of + Specific h2 _ -> + Ambiguous h1 (OneOrMore.more hs1 (OneOrMore.one h2)) + + Ambiguous h2 hs2 -> + Ambiguous h1 (OneOrMore.more hs1 (OneOrMore.more (OneOrMore.one h2) hs2)) + + + +-- VARIABLES + + +type Var + = Local A.Region + | TopLevel A.Region + | Foreign Canonical Can.Annotation + | Foreigns Canonical (OneOrMore.OneOrMore Canonical) + + + +-- TYPES + + +type Type + = Alias Int Canonical (List Name.Name) Can.Type + | Union Int Canonical + + + +-- CTORS + + +type Ctor + = RecordCtor Canonical (List Name.Name) Can.Type + | Ctor Canonical Name.Name Can.Union Index.ZeroBased (List Can.Type) + + + +-- BINOPS + + +type Binop + = Binop Name.Name Canonical Name.Name Can.Annotation Binop.Associativity Binop.Precedence + + + +-- VARIABLE -- ADD LOCALS + + +addLocals : Dict String Name.Name A.Region -> Env -> EResult i w Env +addLocals names env = + R.fmap (\newVars -> { env | vars = newVars }) + (Dict.merge compare + (\name region -> R.fmap (Dict.insert identity name (addLocalLeft name region))) + (\name region var acc -> + addLocalBoth name region var + |> R.bind (\var_ -> R.fmap (Dict.insert identity name var_) acc) + ) + (\name var -> R.fmap (Dict.insert identity name var)) + names + env.vars + (R.ok Dict.empty) + ) + + +addLocalLeft : Name.Name -> A.Region -> Var +addLocalLeft _ region = + Local region + + +addLocalBoth : Name.Name -> A.Region -> Var -> EResult i w Var +addLocalBoth name region var = + case var of + Foreign _ _ -> + R.ok (Local region) + + Foreigns _ _ -> + R.ok (Local region) + + Local parentRegion -> + R.throw (Error.Shadowing name parentRegion region) + + TopLevel parentRegion -> + R.throw (Error.Shadowing name parentRegion region) + + + +-- FIND TYPE + + +findType : A.Region -> Env -> Name.Name -> EResult i w Type +findType region { types, q_types } name = + case Dict.get identity name types of + Just (Specific _ tipe) -> + R.ok tipe + + Just (Ambiguous h hs) -> + R.throw (Error.AmbiguousType region Nothing name h hs) + + Nothing -> + R.throw (Error.NotFoundType region Nothing name (toPossibleNames types q_types)) + + +findTypeQual : A.Region -> Env -> Name.Name -> Name.Name -> EResult i w Type +findTypeQual region { types, q_types } prefix name = + case Dict.get identity prefix q_types of + Just qualified -> + case Dict.get identity name qualified of + Just (Specific _ tipe) -> + R.ok tipe + + Just (Ambiguous h hs) -> + R.throw (Error.AmbiguousType region (Just prefix) name h hs) + + Nothing -> + R.throw (Error.NotFoundType region (Just prefix) name (toPossibleNames types q_types)) + + Nothing -> + R.throw (Error.NotFoundType region (Just prefix) name (toPossibleNames types q_types)) + + + +-- FIND CTOR + + +findCtor : A.Region -> Env -> Name.Name -> EResult i w Ctor +findCtor region { ctors, q_ctors } name = + case Dict.get identity name ctors of + Just (Specific _ ctor) -> + R.ok ctor + + Just (Ambiguous h hs) -> + R.throw (Error.AmbiguousVariant region Nothing name h hs) + + Nothing -> + R.throw (Error.NotFoundVariant region Nothing name (toPossibleNames ctors q_ctors)) + + +findCtorQual : A.Region -> Env -> Name.Name -> Name.Name -> EResult i w Ctor +findCtorQual region { ctors, q_ctors } prefix name = + case Dict.get identity prefix q_ctors of + Just qualified -> + case Dict.get identity name qualified of + Just (Specific _ pattern) -> + R.ok pattern + + Just (Ambiguous h hs) -> + R.throw (Error.AmbiguousVariant region (Just prefix) name h hs) + + Nothing -> + R.throw (Error.NotFoundVariant region (Just prefix) name (toPossibleNames ctors q_ctors)) + + Nothing -> + R.throw (Error.NotFoundVariant region (Just prefix) name (toPossibleNames ctors q_ctors)) + + + +-- FIND BINOP + + +findBinop : A.Region -> Env -> Name.Name -> EResult i w Binop +findBinop region { binops } name = + case Dict.get identity name binops of + Just (Specific _ binop) -> + R.ok binop + + Just (Ambiguous h hs) -> + R.throw (Error.AmbiguousBinop region name h hs) + + Nothing -> + R.throw (Error.NotFoundBinop region name (EverySet.fromList identity (Dict.keys compare binops))) + + + +-- TO POSSIBLE NAMES + + +toPossibleNames : Exposed a -> Qualified a -> Error.PossibleNames +toPossibleNames exposed qualified = + Error.PossibleNames (EverySet.fromList identity (Dict.keys compare exposed)) (Dict.map (\_ -> Dict.keys compare >> EverySet.fromList identity) qualified) diff --git a/src/Compiler/Canonicalize/Environment/Dups.elm b/src/Compiler/Canonicalize/Environment/Dups.elm new file mode 100644 index 0000000000..7198b08171 --- /dev/null +++ b/src/Compiler/Canonicalize/Environment/Dups.elm @@ -0,0 +1,157 @@ +module Compiler.Canonicalize.Environment.Dups exposing + ( Info + , ToError + , Tracker + , checkFields + , checkFields_ + , checkLocatedFields + , checkLocatedFields_ + , detect + , detectLocated + , insert + , none + , one + , union + , unions + ) + +import Compiler.Data.Name exposing (Name) +import Compiler.Data.OneOrMore as OneOrMore exposing (OneOrMore) +import Compiler.Reporting.Annotation as A +import Compiler.Reporting.Error.Canonicalize as Error exposing (Error) +import Compiler.Reporting.Result as R +import Data.Map as Dict exposing (Dict) +import Utils.Main as Utils + + + +-- DUPLICATE TRACKER + + +type alias Tracker value = + Dict String Name (OneOrMore (Info value)) + + +type Info value + = Info A.Region value + + + +-- DETECT + + +type alias ToError = + Name -> A.Region -> A.Region -> Error + + +detect : ToError -> Tracker a -> R.RResult i w Error (Dict String Name a) +detect toError dict = + Dict.foldl compare + (\name values -> + R.bind + (\acc -> + R.fmap (\b -> Dict.insert identity name b acc) + (detectHelp toError name values) + ) + ) + (R.ok Dict.empty) + dict + + +detectLocated : ToError -> Tracker a -> R.RResult i w Error (Dict String (A.Located Name) a) +detectLocated toError dict = + let + nameLocations : Dict String Name A.Region + nameLocations = + Utils.mapMapMaybe identity compare extractLocation dict + in + dict + |> Utils.mapMapKeys A.toValue compare (\k -> A.At (Maybe.withDefault A.zero <| Dict.get identity k nameLocations) k) + |> R.mapTraverseWithKey A.toValue A.compareLocated (\(A.At _ name) values -> detectHelp toError name values) + + +extractLocation : OneOrMore.OneOrMore (Info a) -> Maybe A.Region +extractLocation oneOrMore = + case oneOrMore of + OneOrMore.One (Info region _) -> + Just region + + OneOrMore.More _ _ -> + Nothing + + +detectHelp : ToError -> Name -> OneOrMore (Info a) -> R.RResult i w Error a +detectHelp toError name values = + case values of + OneOrMore.One (Info _ value) -> + R.ok value + + OneOrMore.More left right -> + let + ( Info r1 _, Info r2 _ ) = + OneOrMore.getFirstTwo left right + in + R.throw (toError name r1 r2) + + + +-- CHECK FIELDS + + +checkLocatedFields : List ( A.Located Name, a ) -> R.RResult i w Error (Dict String (A.Located Name) a) +checkLocatedFields fields = + detectLocated Error.DuplicateField (List.foldr addField none fields) + + +checkFields : List ( A.Located Name, a ) -> R.RResult i w Error (Dict String Name a) +checkFields fields = + detect Error.DuplicateField (List.foldr addField none fields) + + +addField : ( A.Located Name, a ) -> Tracker a -> Tracker a +addField ( A.At region name, value ) dups = + Utils.mapInsertWith identity OneOrMore.more name (OneOrMore.one (Info region value)) dups + + +checkLocatedFields_ : (A.Region -> a -> b) -> List ( A.Located Name, a ) -> R.RResult i w Error (Dict String (A.Located Name) b) +checkLocatedFields_ toValue fields = + detectLocated Error.DuplicateField (List.foldr (addField_ toValue) none fields) + + +checkFields_ : (A.Region -> a -> b) -> List ( A.Located Name, a ) -> R.RResult i w Error (Dict String Name b) +checkFields_ toValue fields = + detect Error.DuplicateField (List.foldr (addField_ toValue) none fields) + + +addField_ : (A.Region -> a -> b) -> ( A.Located Name, a ) -> Tracker b -> Tracker b +addField_ toValue ( A.At region name, value ) dups = + Utils.mapInsertWith identity OneOrMore.more name (OneOrMore.one (Info region (toValue region value))) dups + + + +-- BUILDING DICTIONARIES + + +none : Tracker a +none = + Dict.empty + + +one : Name -> A.Region -> value -> Tracker value +one name region value = + Dict.singleton identity name (OneOrMore.one (Info region value)) + + +insert : Name -> A.Region -> a -> Tracker a -> Tracker a +insert name region value dict = + Utils.mapInsertWith identity (\new old -> OneOrMore.more old new) name (OneOrMore.one (Info region value)) dict + + +union : Tracker a -> Tracker a -> Tracker a +union a b = + Utils.mapUnionWith identity compare OneOrMore.more a b + + +unions : List (Tracker a) -> Tracker a +unions dicts = + List.foldl union Dict.empty dicts diff --git a/src/Compiler/Canonicalize/Environment/Foreign.elm b/src/Compiler/Canonicalize/Environment/Foreign.elm new file mode 100644 index 0000000000..d52d5384d5 --- /dev/null +++ b/src/Compiler/Canonicalize/Environment/Foreign.elm @@ -0,0 +1,371 @@ +module Compiler.Canonicalize.Environment.Foreign exposing (FResult, createInitialEnv) + +import Compiler.AST.Canonical as Can +import Compiler.AST.Source as Src +import Compiler.Canonicalize.Environment as Env +import Compiler.Data.Name as Name exposing (Name) +import Compiler.Elm.Interface as I +import Compiler.Elm.ModuleName as ModuleName +import Compiler.Elm.Package as Pkg +import Compiler.Reporting.Annotation as A +import Compiler.Reporting.Error.Canonicalize as Error +import Compiler.Reporting.Result as R +import Data.Map as Dict exposing (Dict) +import System.TypeCheck.IO as IO +import Utils.Crash exposing (crash) +import Utils.Main as Utils + + +type alias FResult i w a = + R.RResult i w Error.Error a + + +createInitialEnv : IO.Canonical -> Dict String ModuleName.Raw I.Interface -> List Src.Import -> FResult i w Env.Env +createInitialEnv home ifaces imports = + Utils.foldM (addImport ifaces) emptyState (toSafeImports home imports) + |> R.fmap + (\{ vars, types, ctors, binops, q_vars, q_types, q_ctors } -> + Env.Env home + (Dict.map (\_ -> infoToVar) vars) + types + ctors + binops + q_vars + q_types + q_ctors + ) + + +infoToVar : Env.Info Can.Annotation -> Env.Var +infoToVar info = + case info of + Env.Specific home tipe -> + Env.Foreign home tipe + + Env.Ambiguous h hs -> + Env.Foreigns h hs + + + +-- STATE + + +type alias State = + { vars : Env.Exposed Can.Annotation + , types : Env.Exposed Env.Type + , ctors : Env.Exposed Env.Ctor + , binops : Env.Exposed Env.Binop + , q_vars : Env.Qualified Can.Annotation + , q_types : Env.Qualified Env.Type + , q_ctors : Env.Qualified Env.Ctor + } + + +emptyState : State +emptyState = + State Dict.empty emptyTypes Dict.empty Dict.empty Dict.empty Dict.empty Dict.empty + + +emptyTypes : Env.Exposed Env.Type +emptyTypes = + Dict.fromList identity [ ( "List", Env.Specific ModuleName.list (Env.Union 1 ModuleName.list) ) ] + + + +-- TO SAFE IMPORTS + + +toSafeImports : IO.Canonical -> List Src.Import -> List Src.Import +toSafeImports (IO.Canonical package _) imports = + if Pkg.isKernel package then + List.filter isNormal imports + + else + imports + + +isNormal : Src.Import -> Bool +isNormal (Src.Import ( _, A.At _ name ) maybeAlias _) = + if Name.isKernel name then + case maybeAlias of + Nothing -> + False + + Just _ -> + crash "kernel imports cannot use `as`" + + else + True + + + +-- ADD IMPORTS + + +addImport : Dict String ModuleName.Raw I.Interface -> State -> Src.Import -> FResult i w State +addImport ifaces state (Src.Import ( _, A.At _ name ) maybeAlias ( _, exposing_ )) = + let + (I.Interface pkg defs unions aliases binops) = + Utils.find identity name ifaces + + prefix : Name + prefix = + Maybe.withDefault name (Maybe.map Src.c2Value maybeAlias) + + home : IO.Canonical + home = + IO.Canonical pkg name + + rawTypeInfo : Dict String Name ( Env.Type, Env.Exposed Env.Ctor ) + rawTypeInfo = + Dict.union + (Dict.toList compare unions + |> List.filterMap (\( k, a ) -> Maybe.map (Tuple.pair k) (unionToType home k a)) + |> Dict.fromList identity + ) + (Dict.toList compare aliases + |> List.filterMap (\( k, a ) -> Maybe.map (Tuple.pair k) (aliasToType home k a)) + |> Dict.fromList identity + ) + + vars : Dict String Name (Env.Info Can.Annotation) + vars = + Dict.map (\_ -> Env.Specific home) defs + + types : Dict String Name (Env.Info Env.Type) + types = + Dict.map (\_ -> Env.Specific home << Tuple.first) rawTypeInfo + + ctors : Env.Exposed Env.Ctor + ctors = + Dict.foldr compare (\_ -> addExposed << Tuple.second) Dict.empty rawTypeInfo + + qvs2 : Env.Qualified Can.Annotation + qvs2 = + addQualified prefix vars state.q_vars + + qts2 : Env.Qualified Env.Type + qts2 = + addQualified prefix types state.q_types + + qcs2 : Env.Qualified Env.Ctor + qcs2 = + addQualified prefix ctors state.q_ctors + in + case exposing_ of + Src.Open _ _ -> + let + vs2 : Env.Exposed Can.Annotation + vs2 = + addExposed state.vars vars + + ts2 : Env.Exposed Env.Type + ts2 = + addExposed state.types types + + cs2 : Env.Exposed Env.Ctor + cs2 = + addExposed state.ctors ctors + + bs2 : Env.Exposed Env.Binop + bs2 = + addExposed state.binops (Dict.map (binopToBinop home) binops) + in + R.ok (State vs2 ts2 cs2 bs2 qvs2 qts2 qcs2) + + Src.Explicit (A.At _ exposedList) -> + Utils.foldM + (addExposedValue home vars rawTypeInfo binops) + (State state.vars state.types state.ctors state.binops qvs2 qts2 qcs2) + (List.map Src.c2Value exposedList) + + +addExposed : Env.Exposed a -> Env.Exposed a -> Env.Exposed a +addExposed = + Utils.mapUnionWith identity compare Env.mergeInfo + + +addQualified : Name -> Env.Exposed a -> Env.Qualified a -> Env.Qualified a +addQualified prefix exposed qualified = + Utils.mapInsertWith identity addExposed prefix exposed qualified + + + +-- UNION + + +unionToType : IO.Canonical -> Name -> I.Union -> Maybe ( Env.Type, Env.Exposed Env.Ctor ) +unionToType home name union = + Maybe.map (unionToTypeHelp home name) (I.toPublicUnion union) + + +unionToTypeHelp : IO.Canonical -> Name -> Can.Union -> ( Env.Type, Env.Exposed Env.Ctor ) +unionToTypeHelp home name ((Can.Union vars ctors _ _) as union) = + let + addCtor : Can.Ctor -> Dict String Name (Env.Info Env.Ctor) -> Dict String Name (Env.Info Env.Ctor) + addCtor (Can.Ctor ctor index _ args) dict = + Dict.insert identity ctor (Env.Specific home (Env.Ctor home name union index args)) dict + in + ( Env.Union (List.length vars) home + , List.foldl addCtor Dict.empty ctors + ) + + + +-- ALIAS + + +aliasToType : IO.Canonical -> Name -> I.Alias -> Maybe ( Env.Type, Env.Exposed Env.Ctor ) +aliasToType home name alias = + Maybe.map (aliasToTypeHelp home name) (I.toPublicAlias alias) + + +aliasToTypeHelp : IO.Canonical -> Name -> Can.Alias -> ( Env.Type, Env.Exposed Env.Ctor ) +aliasToTypeHelp home name (Can.Alias vars tipe) = + ( Env.Alias (List.length vars) home vars tipe + , case tipe of + Can.TRecord fields Nothing -> + let + avars : List ( Name, Can.Type ) + avars = + List.map (\var -> ( var, Can.TVar var )) vars + + alias_ : Can.Type + alias_ = + List.foldr + (\( _, t1 ) t2 -> Can.TLambda t1 t2) + (Can.TAlias home name avars (Can.Filled tipe)) + (Can.fieldsToList fields) + in + Dict.singleton identity name (Env.Specific home (Env.RecordCtor home vars alias_)) + + _ -> + Dict.empty + ) + + + +-- BINOP + + +binopToBinop : IO.Canonical -> Name -> I.Binop -> Env.Info Env.Binop +binopToBinop home op (I.Binop name annotation associativity precedence) = + Env.Specific home (Env.Binop op home name annotation associativity precedence) + + + +-- ADD EXPOSED VALUE + + +addExposedValue : + IO.Canonical + -> Env.Exposed Can.Annotation + -> Dict String Name ( Env.Type, Env.Exposed Env.Ctor ) + -> Dict String Name I.Binop + -> State + -> Src.Exposed + -> FResult i w State +addExposedValue home vars types binops state exposed = + case exposed of + Src.Lower (A.At region name) -> + case Dict.get identity name vars of + Just info -> + R.ok { state | vars = Utils.mapInsertWith identity Env.mergeInfo name info state.vars } + + Nothing -> + R.throw (Error.ImportExposingNotFound region home name (Dict.keys compare vars)) + + Src.Upper (A.At region name) ( _, privacy ) -> + case privacy of + Src.Private -> + case Dict.get identity name types of + Just ( tipe, ctors ) -> + case tipe of + Env.Union _ _ -> + let + ts2 : Dict String Name (Env.Info Env.Type) + ts2 = + Dict.insert identity name (Env.Specific home tipe) state.types + in + R.ok { state | types = ts2 } + + Env.Alias _ _ _ _ -> + let + ts2 : Dict String Name (Env.Info Env.Type) + ts2 = + Dict.insert identity name (Env.Specific home tipe) state.types + + cs2 : Env.Exposed Env.Ctor + cs2 = + addExposed state.ctors ctors + in + R.ok { state | types = ts2, ctors = cs2 } + + Nothing -> + case checkForCtorMistake name types of + tipe :: _ -> + R.throw <| Error.ImportCtorByName region name tipe + + [] -> + R.throw <| Error.ImportExposingNotFound region home name (Dict.keys compare types) + + Src.Public dotDotRegion -> + case Dict.get identity name types of + Just ( tipe, ctors ) -> + case tipe of + Env.Union _ _ -> + let + ts2 : Dict String Name (Env.Info Env.Type) + ts2 = + Dict.insert identity name (Env.Specific home tipe) state.types + + cs2 : Env.Exposed Env.Ctor + cs2 = + addExposed state.ctors ctors + in + R.ok { state | types = ts2, ctors = cs2 } + + Env.Alias _ _ _ _ -> + R.throw (Error.ImportOpenAlias dotDotRegion name) + + Nothing -> + R.throw (Error.ImportExposingNotFound region home name (Dict.keys compare types)) + + Src.Operator region op -> + case Dict.get identity op binops of + Just binop -> + let + bs2 : Dict String Name (Env.Info Env.Binop) + bs2 = + Dict.insert identity op (binopToBinop home op binop) state.binops + in + R.ok { state | binops = bs2 } + + Nothing -> + R.throw (Error.ImportExposingNotFound region home op (Dict.keys compare binops)) + + +checkForCtorMistake : Name -> Dict String Name ( Env.Type, Env.Exposed Env.Ctor ) -> List Name +checkForCtorMistake givenName types = + let + addMatches : a -> ( b, Dict String Name (Env.Info Env.Ctor) ) -> List Name -> List Name + addMatches _ ( _, exposedCtors ) matches = + Dict.foldr compare addMatch matches exposedCtors + + addMatch : Name -> Env.Info Env.Ctor -> List Name -> List Name + addMatch ctorName info matches = + if ctorName /= givenName then + matches + + else + case info of + Env.Specific _ (Env.Ctor _ tipeName _ _ _) -> + tipeName :: matches + + Env.Specific _ (Env.RecordCtor _ _ _) -> + matches + + Env.Ambiguous _ _ -> + matches + in + Dict.foldr compare addMatches [] types diff --git a/src/Compiler/Canonicalize/Environment/Local.elm b/src/Compiler/Canonicalize/Environment/Local.elm new file mode 100644 index 0000000000..a076642e42 --- /dev/null +++ b/src/Compiler/Canonicalize/Environment/Local.elm @@ -0,0 +1,475 @@ +module Compiler.Canonicalize.Environment.Local exposing (LResult, add) + +import Compiler.AST.Canonical as Can +import Compiler.AST.Source as Src +import Compiler.Canonicalize.Environment as Env +import Compiler.Canonicalize.Environment.Dups as Dups +import Compiler.Canonicalize.Type as Type +import Compiler.Data.Index as Index +import Compiler.Data.Name as Name exposing (Name) +import Compiler.Parse.SyntaxVersion exposing (SyntaxVersion) +import Compiler.Reporting.Annotation as A +import Compiler.Reporting.Error.Canonicalize as Error +import Compiler.Reporting.Result as R +import Data.Graph as Graph +import Data.Map as Dict exposing (Dict) +import System.TypeCheck.IO as IO +import Utils.Main as Utils + + + +-- RESULT + + +type alias LResult i w a = + R.RResult i w Error.Error a + + +type alias Unions = + Dict String Name Can.Union + + +type alias Aliases = + Dict String Name Can.Alias + + +add : Src.Module -> Env.Env -> LResult i w ( Env.Env, Unions, Aliases ) +add module_ env = + addTypes module_ env + |> R.bind (addVars module_) + |> R.bind (addCtors module_) + + + +-- ADD VARS + + +addVars : Src.Module -> Env.Env -> LResult i w Env.Env +addVars module_ env = + collectVars module_ + |> R.fmap + (\topLevelVars -> + let + vs2 : Dict String Name Env.Var + vs2 = + Dict.union topLevelVars env.vars + in + -- Use union to overwrite foreign stuff. + { env | vars = vs2 } + ) + + +collectVars : Src.Module -> LResult i w (Dict String Name.Name Env.Var) +collectVars (Src.Module _ _ _ _ _ values _ _ _ effects) = + let + addDecl : A.Located Src.Value -> Dups.Tracker Env.Var -> Dups.Tracker Env.Var + addDecl (A.At _ (Src.Value _ ( _, A.At region name ) _ _ _)) = + Dups.insert name region (Env.TopLevel region) + in + Dups.detect Error.DuplicateDecl <| + List.foldl addDecl (toEffectDups effects) values + + +toEffectDups : Src.Effects -> Dups.Tracker Env.Var +toEffectDups effects = + case effects of + Src.NoEffects -> + Dups.none + + Src.Ports ports -> + let + addPort : Src.Port -> Dups.Tracker Env.Var -> Dups.Tracker Env.Var + addPort (Src.Port _ ( _, A.At region name ) _) = + Dups.insert name region (Env.TopLevel region) + in + List.foldl addPort Dups.none ports + + Src.Manager _ manager -> + case manager of + Src.Cmd ( _, ( _, A.At region _ ) ) -> + Dups.one "command" region (Env.TopLevel region) + + Src.Sub ( _, ( _, A.At region _ ) ) -> + Dups.one "subscription" region (Env.TopLevel region) + + Src.Fx ( _, ( _, A.At regionCmd _ ) ) ( _, ( _, A.At regionSub _ ) ) -> + Dups.union + (Dups.one "command" regionCmd (Env.TopLevel regionCmd)) + (Dups.one "subscription" regionSub (Env.TopLevel regionSub)) + + + +-- ADD TYPES + + +addTypes : Src.Module -> Env.Env -> LResult i w Env.Env +addTypes (Src.Module syntaxVersion _ _ _ _ _ unions aliases _ _) env = + let + addAliasDups : A.Located Src.Alias -> Dups.Tracker () -> Dups.Tracker () + addAliasDups (A.At _ (Src.Alias _ ( _, A.At region name ) _ _)) = + Dups.insert name region () + + addUnionDups : A.Located Src.Union -> Dups.Tracker () -> Dups.Tracker () + addUnionDups (A.At _ (Src.Union ( _, A.At region name ) _ _)) = + Dups.insert name region () + + typeNameDups : Dups.Tracker () + typeNameDups = + List.foldl addUnionDups (List.foldl addAliasDups Dups.none aliases) unions + in + Dups.detect Error.DuplicateType typeNameDups + |> R.bind + (\_ -> + Utils.foldM (addUnion env.home) env.types unions + |> R.bind (\ts1 -> addAliases syntaxVersion aliases <| { env | types = ts1 }) + ) + + +addUnion : IO.Canonical -> Env.Exposed Env.Type -> A.Located Src.Union -> LResult i w (Env.Exposed Env.Type) +addUnion home types ((A.At _ (Src.Union ( _, A.At _ name ) _ _)) as union) = + R.fmap + (\arity -> + let + one : Env.Info Env.Type + one = + Env.Specific home (Env.Union arity home) + in + Dict.insert identity name one types + ) + (checkUnionFreeVars union) + + + +-- ADD TYPE ALIASES + + +addAliases : SyntaxVersion -> List (A.Located Src.Alias) -> Env.Env -> LResult i w Env.Env +addAliases syntaxVersion aliases env = + let + nodes : List ( A.Located Src.Alias, Name, List Name ) + nodes = + List.map toNode aliases + + sccs : List (Graph.SCC (A.Located Src.Alias)) + sccs = + Graph.stronglyConnComp nodes + in + Utils.foldM (addAlias syntaxVersion) env sccs + + +addAlias : SyntaxVersion -> Env.Env -> Graph.SCC (A.Located Src.Alias) -> LResult i w Env.Env +addAlias syntaxVersion ({ home, vars, types, ctors, binops, q_vars, q_types, q_ctors } as env) scc = + case scc of + Graph.AcyclicSCC ((A.At _ (Src.Alias _ ( _, A.At _ name ) _ ( _, tipe ))) as alias) -> + checkAliasFreeVars alias + |> R.bind + (\args -> + Type.canonicalize syntaxVersion env tipe + |> R.bind + (\ctype -> + let + one : Env.Info Env.Type + one = + Env.Specific home (Env.Alias (List.length args) home args ctype) + + ts1 : Dict String Name (Env.Info Env.Type) + ts1 = + Dict.insert identity name one types + in + R.ok (Env.Env home vars ts1 ctors binops q_vars q_types q_ctors) + ) + ) + + Graph.CyclicSCC [] -> + R.ok env + + Graph.CyclicSCC (((A.At _ (Src.Alias _ ( _, A.At region name1 ) _ ( _, tipe ))) as alias) :: others) -> + checkAliasFreeVars alias + |> R.bind + (\args -> + let + toName : A.Located Src.Alias -> Name + toName (A.At _ (Src.Alias _ ( _, A.At _ name ) _ _)) = + name + in + R.throw (Error.RecursiveAlias region name1 args tipe (List.map toName others)) + ) + + + +-- DETECT TYPE ALIAS CYCLES + + +toNode : A.Located Src.Alias -> ( A.Located Src.Alias, Name.Name, List Name.Name ) +toNode ((A.At _ (Src.Alias _ ( _, A.At _ name ) _ ( _, tipe ))) as alias) = + ( alias, name, getEdges tipe [] ) + + +getEdges : Src.Type -> List Name.Name -> List Name.Name +getEdges (A.At _ tipe) edges = + case tipe of + Src.TLambda ( _, arg ) ( _, result ) -> + getEdges result (getEdges arg edges) + + Src.TVar _ -> + edges + + Src.TType _ name args -> + List.foldl getEdges (name :: edges) (List.map Src.c1Value args) + + Src.TTypeQual _ _ _ args -> + List.foldl getEdges edges (List.map Src.c1Value args) + + Src.TRecord fields _ _ -> + List.foldl (\( _, ( _, ( _, t ) ) ) es -> getEdges t es) edges fields + + Src.TUnit -> + edges + + Src.TTuple ( _, a ) ( _, b ) cs -> + List.foldl getEdges (getEdges b (getEdges a edges)) (List.map Src.c2EolValue cs) + + Src.TParens ( _, tipe_ ) -> + getEdges tipe_ edges + + + +-- CHECK FREE VARIABLES + + +checkUnionFreeVars : A.Located Src.Union -> LResult i w Int +checkUnionFreeVars (A.At unionRegion (Src.Union ( _, A.At _ name ) args ctors)) = + let + addArg : A.Located Name -> Dups.Tracker A.Region -> Dups.Tracker A.Region + addArg (A.At region arg) dict = + Dups.insert arg region region dict + + addCtorFreeVars : ( a, List Src.Type ) -> Dict String Name A.Region -> Dict String Name A.Region + addCtorFreeVars ( _, tipes ) freeVars = + List.foldl addFreeVars freeVars tipes + in + Dups.detect (Error.DuplicateUnionArg name) (List.foldr addArg Dups.none (List.map Src.c1Value args)) + |> R.bind + (\boundVars -> + let + freeVars : Dict String Name A.Region + freeVars = + List.foldr addCtorFreeVars Dict.empty (List.map (Src.c2EolValue >> Tuple.mapSecond (List.map Src.c1Value)) ctors) + in + case Dict.toList compare (Dict.diff freeVars boundVars) of + [] -> + R.ok (List.length args) + + unbound :: unbounds -> + R.throw <| + Error.TypeVarsUnboundInUnion unionRegion name (List.map (Src.c1Value >> A.toValue) args) unbound unbounds + ) + + +checkAliasFreeVars : A.Located Src.Alias -> LResult i w (List Name.Name) +checkAliasFreeVars (A.At aliasRegion (Src.Alias _ ( _, A.At _ name ) args ( _, tipe ))) = + let + addArg : Src.C1 (A.Located Name) -> Dups.Tracker A.Region -> Dups.Tracker A.Region + addArg ( _, A.At region arg ) dict = + Dups.insert arg region region dict + in + Dups.detect (Error.DuplicateAliasArg name) (List.foldr addArg Dups.none args) + |> R.bind + (\boundVars -> + let + freeVars : Dict String Name A.Region + freeVars = + addFreeVars tipe Dict.empty + + overlap : Int + overlap = + Dict.size (Dict.intersection compare boundVars freeVars) + in + if Dict.size boundVars == overlap && Dict.size freeVars == overlap then + R.ok (List.map (Src.c1Value >> A.toValue) args) + + else + R.throw <| + Error.TypeVarsMessedUpInAlias aliasRegion + name + (List.map (Src.c1Value >> A.toValue) args) + (Dict.toList compare (Dict.diff boundVars freeVars)) + (Dict.toList compare (Dict.diff freeVars boundVars)) + ) + + +addFreeVars : Src.Type -> Dict String Name.Name A.Region -> Dict String Name.Name A.Region +addFreeVars (A.At region tipe) freeVars = + case tipe of + Src.TLambda ( _, arg ) ( _, result ) -> + addFreeVars result (addFreeVars arg freeVars) + + Src.TVar name -> + Dict.insert identity name region freeVars + + Src.TType _ _ args -> + List.foldl addFreeVars freeVars (List.map Src.c1Value args) + + Src.TTypeQual _ _ _ args -> + List.foldl addFreeVars freeVars (List.map Src.c1Value args) + + Src.TRecord fields maybeExt _ -> + let + extFreeVars : Dict String Name A.Region + extFreeVars = + case maybeExt of + Nothing -> + freeVars + + Just ( _, A.At extRegion ext ) -> + Dict.insert identity ext extRegion freeVars + in + List.foldl (\( _, ( _, ( _, t ) ) ) fvs -> addFreeVars t fvs) extFreeVars fields + + Src.TUnit -> + freeVars + + Src.TTuple ( _, a ) ( _, b ) cs -> + List.foldl addFreeVars (addFreeVars b (addFreeVars a freeVars)) (List.map Src.c2EolValue cs) + + Src.TParens ( _, tipe_ ) -> + addFreeVars tipe_ freeVars + + + +-- ADD CTORS + + +addCtors : Src.Module -> Env.Env -> LResult i w ( Env.Env, Unions, Aliases ) +addCtors (Src.Module syntaxVersion _ _ _ _ _ unions aliases _ _) env = + R.traverse (canonicalizeUnion syntaxVersion env) unions + |> R.bind + (\unionInfo -> + R.traverse (canonicalizeAlias syntaxVersion env) aliases + |> R.bind + (\aliasInfo -> + (Dups.detect Error.DuplicateCtor <| + Dups.union + (Dups.unions (List.map Tuple.second unionInfo)) + (Dups.unions (List.map Tuple.second aliasInfo)) + ) + |> R.bind + (\ctors -> + let + cs2 : Dict String Name (Env.Info Env.Ctor) + cs2 = + Dict.union ctors env.ctors + in + R.ok + ( { env | ctors = cs2 } + , Dict.fromList identity (List.map Tuple.first unionInfo) + , Dict.fromList identity (List.map Tuple.first aliasInfo) + ) + ) + ) + ) + + +type alias CtorDups = + Dups.Tracker (Env.Info Env.Ctor) + + + +-- CANONICALIZE ALIAS + + +canonicalizeAlias : SyntaxVersion -> Env.Env -> A.Located Src.Alias -> LResult i w ( ( Name.Name, Can.Alias ), CtorDups ) +canonicalizeAlias syntaxVersion ({ home } as env) (A.At _ (Src.Alias _ ( _, A.At region name ) args ( _, tipe ))) = + let + vars : List Name + vars = + List.map (Src.c1Value >> A.toValue) args + in + Type.canonicalize syntaxVersion env tipe + |> R.bind + (\ctipe -> + R.ok + ( ( name, Can.Alias vars ctipe ) + , case ctipe of + Can.TRecord fields Nothing -> + Dups.one name region (Env.Specific home (toRecordCtor home name vars fields)) + + _ -> + Dups.none + ) + ) + + +toRecordCtor : IO.Canonical -> Name.Name -> List Name.Name -> Dict String Name.Name Can.FieldType -> Env.Ctor +toRecordCtor home name vars fields = + let + avars : List ( Name, Can.Type ) + avars = + List.map (\var -> ( var, Can.TVar var )) vars + + alias : Can.Type + alias = + List.foldr + (\( _, t1 ) t2 -> Can.TLambda t1 t2) + (Can.TAlias home name avars (Can.Filled (Can.TRecord fields Nothing))) + (Can.fieldsToList fields) + in + Env.RecordCtor home vars alias + + + +-- CANONICALIZE UNION + + +canonicalizeUnion : SyntaxVersion -> Env.Env -> A.Located Src.Union -> LResult i w ( ( Name.Name, Can.Union ), CtorDups ) +canonicalizeUnion syntaxVersion ({ home } as env) (A.At _ (Src.Union ( _, A.At _ name ) avars ctors)) = + R.indexedTraverse (canonicalizeCtor syntaxVersion env) (List.map (Tuple.mapSecond (List.map Src.c1Value)) (List.map Src.c2EolValue ctors)) + |> R.bind + (\cctors -> + let + vars : List Name + vars = + List.map (Src.c1Value >> A.toValue) avars + + alts : List Can.Ctor + alts = + List.map A.toValue cctors + + union : Can.Union + union = + Can.Union vars alts (List.length alts) (toOpts ctors) + in + R.ok ( ( name, union ), Dups.unions (List.map (toCtor home name union) cctors) ) + ) + + +canonicalizeCtor : SyntaxVersion -> Env.Env -> Index.ZeroBased -> ( A.Located Name.Name, List Src.Type ) -> LResult i w (A.Located Can.Ctor) +canonicalizeCtor syntaxVersion env index ( A.At region ctor, tipes ) = + R.traverse (Type.canonicalize syntaxVersion env) tipes + |> R.bind + (\ctipes -> + R.ok <| + A.At region <| + Can.Ctor ctor index (List.length ctipes) ctipes + ) + + +toOpts : List (Src.C2Eol ( A.Located Name.Name, List (Src.C1 Src.Type) )) -> Can.CtorOpts +toOpts ctors = + case ctors of + [ ( _, ( _, [ _ ] ) ) ] -> + Can.Unbox + + _ -> + if List.all (List.isEmpty << Tuple.second) (List.map Src.c2EolValue ctors) then + Can.Enum + + else + Can.Normal + + +toCtor : IO.Canonical -> Name.Name -> Can.Union -> A.Located Can.Ctor -> CtorDups +toCtor home typeName union (A.At region (Can.Ctor name index _ args)) = + Dups.one name region <| + Env.Specific home <| + Env.Ctor home typeName union index args diff --git a/src/Compiler/Canonicalize/Expression.elm b/src/Compiler/Canonicalize/Expression.elm new file mode 100644 index 0000000000..76e7eba202 --- /dev/null +++ b/src/Compiler/Canonicalize/Expression.elm @@ -0,0 +1,897 @@ +module Compiler.Canonicalize.Expression exposing + ( EResult + , FreeLocals + , Uses(..) + , canonicalize + , gatherTypedArgs + , verifyBindings + ) + +import Basics.Extra exposing (flip) +import Compiler.AST.Canonical as Can +import Compiler.AST.Source as Src +import Compiler.AST.Utils.Binop as Binop +import Compiler.AST.Utils.Type as Type +import Compiler.Canonicalize.Environment as Env +import Compiler.Canonicalize.Environment.Dups as Dups +import Compiler.Canonicalize.Pattern as Pattern +import Compiler.Canonicalize.Type as Type +import Compiler.Data.Index as Index +import Compiler.Data.Name as Name exposing (Name) +import Compiler.Elm.ModuleName as ModuleName +import Compiler.Elm.Package as Pkg +import Compiler.Parse.SyntaxVersion as SV exposing (SyntaxVersion) +import Compiler.Reporting.Annotation as A +import Compiler.Reporting.Error.Canonicalize as Error +import Compiler.Reporting.Result as R +import Compiler.Reporting.Warning as W +import Data.Graph as Graph +import Data.Map as Dict exposing (Dict) +import Prelude +import System.TypeCheck.IO as IO +import Utils.Main as Utils + + + +-- RESULTS + + +type alias EResult i w a = + R.RResult i w Error.Error a + + +type alias FreeLocals = + Dict String Name.Name Uses + + +type Uses + = Uses + { direct : Int + , delayed : Int + } + + + +-- CANONICALIZE + + +canonicalize : SyntaxVersion -> Env.Env -> Src.Expr -> EResult FreeLocals (List W.Warning) Can.Expr +canonicalize syntaxVersion env (A.At region expression) = + R.fmap (A.At region) <| + case expression of + Src.Str string _ -> + R.ok (Can.Str string) + + Src.Chr char -> + R.ok (Can.Chr char) + + Src.Int int _ -> + R.ok (Can.Int int) + + Src.Float float _ -> + R.ok (Can.Float float) + + Src.Var varType name -> + case varType of + Src.LowVar -> + findVar region env name + + Src.CapVar -> + R.fmap (toVarCtor name) (Env.findCtor region env name) + + Src.VarQual varType prefix name -> + case varType of + Src.LowVar -> + findVarQual region env prefix name + + Src.CapVar -> + R.fmap (toVarCtor name) (Env.findCtorQual region env prefix name) + + Src.List exprs _ -> + R.fmap Can.List (R.traverse (canonicalize syntaxVersion env) (List.map Tuple.second exprs)) + + Src.Op op -> + Env.findBinop region env op + |> R.fmap + (\(Env.Binop _ home name annotation _ _) -> + Can.VarOperator op home name annotation + ) + + Src.Negate expr -> + R.fmap Can.Negate (canonicalize syntaxVersion env expr) + + Src.Binops ops final -> + R.fmap A.toValue (canonicalizeBinops syntaxVersion region env (List.map (Tuple.mapSecond Src.c2Value) ops) final) + + Src.Lambda ( _, srcArgs ) ( _, body ) -> + delayedUsage <| + (Pattern.verify Error.DPLambdaArgs + (R.traverse (Pattern.canonicalize syntaxVersion env) (List.map Src.c1Value srcArgs)) + |> R.bind + (\( args, bindings ) -> + Env.addLocals bindings env + |> R.bind + (\newEnv -> + verifyBindings W.Pattern bindings (canonicalize syntaxVersion newEnv body) + |> R.fmap + (\( cbody, freeLocals ) -> + ( Can.Lambda args cbody, freeLocals ) + ) + ) + ) + ) + + Src.Call func args -> + R.fmap Can.Call (canonicalize syntaxVersion env func) + |> R.apply (R.traverse (canonicalize syntaxVersion env) (List.map Src.c1Value args)) + + Src.If firstBranch branches finally -> + R.fmap Can.If + (R.traverse (canonicalizeIfBranch syntaxVersion env) + (List.map (Src.c1Value >> Tuple.mapBoth Src.c2Value Src.c2Value) (firstBranch :: branches)) + ) + |> R.apply (canonicalize syntaxVersion env (Src.c1Value finally)) + + Src.Let defs _ expr -> + R.fmap A.toValue (canonicalizeLet syntaxVersion region env (List.map Src.c2Value defs) expr) + + Src.Case expr branches -> + R.fmap Can.Case (canonicalize syntaxVersion env (Src.c2Value expr)) + |> R.apply (R.traverse (canonicalizeCaseBranch syntaxVersion env) (List.map (Tuple.mapBoth Src.c2Value Src.c1Value) branches)) + + Src.Accessor field -> + R.pure (Can.Accessor field) + + Src.Access record field -> + R.fmap Can.Access (canonicalize syntaxVersion env record) + |> R.apply (R.ok field) + + Src.Update ( _, name ) ( _, fields ) -> + let + makeCanFields : R.RResult i w Error.Error (Dict String (A.Located Name) (R.RResult FreeLocals (List W.Warning) Error.Error Can.FieldUpdate)) + makeCanFields = + Dups.checkLocatedFields_ (\r t -> R.fmap (Can.FieldUpdate r) (canonicalize syntaxVersion env t)) (List.map (Src.c2EolValue >> Tuple.mapBoth Src.c1Value Src.c1Value) fields) + in + R.fmap Can.Update (canonicalize syntaxVersion env name) + |> R.apply (R.bind (Utils.sequenceADict A.toValue A.compareLocated) makeCanFields) + + Src.Record ( _, fields ) -> + Dups.checkLocatedFields (List.map (Src.c2EolValue >> Tuple.mapBoth Src.c1Value Src.c1Value) fields) + |> R.bind + (\fieldDict -> + R.fmap Can.Record (R.traverseDict A.toValue A.compareLocated (canonicalize syntaxVersion env) fieldDict) + ) + + Src.Unit -> + R.ok Can.Unit + + Src.Tuple ( _, a ) ( _, b ) cs -> + R.fmap Can.Tuple (canonicalize syntaxVersion env a) + |> R.apply (canonicalize syntaxVersion env b) + |> R.apply (canonicalizeTupleExtras syntaxVersion region env (List.map Src.c2Value cs)) + + Src.Shader src tipe -> + R.ok (Can.Shader src tipe) + + Src.Parens ( _, expr ) -> + R.fmap A.toValue (canonicalize syntaxVersion env expr) + + +canonicalizeTupleExtras : SyntaxVersion -> A.Region -> Env.Env -> List Src.Expr -> EResult FreeLocals (List W.Warning) (List Can.Expr) +canonicalizeTupleExtras syntaxVersion region env extras = + case extras of + [] -> + R.ok [] + + [ three ] -> + R.fmap List.singleton <| canonicalize syntaxVersion env three + + _ -> + case syntaxVersion of + SV.Elm -> + R.throw (Error.TupleLargerThanThree region) + + SV.Guida -> + R.traverse (canonicalize syntaxVersion env) extras + + + +-- CANONICALIZE IF BRANCH + + +canonicalizeIfBranch : SyntaxVersion -> Env.Env -> ( Src.Expr, Src.Expr ) -> EResult FreeLocals (List W.Warning) ( Can.Expr, Can.Expr ) +canonicalizeIfBranch syntaxVersion env ( condition, branch ) = + R.fmap Tuple.pair (canonicalize syntaxVersion env condition) + |> R.apply (canonicalize syntaxVersion env branch) + + + +-- CANONICALIZE CASE BRANCH + + +canonicalizeCaseBranch : SyntaxVersion -> Env.Env -> ( Src.Pattern, Src.Expr ) -> EResult FreeLocals (List W.Warning) Can.CaseBranch +canonicalizeCaseBranch syntaxVersion env ( pattern, expr ) = + directUsage + (Pattern.verify Error.DPCaseBranch + (Pattern.canonicalize syntaxVersion env pattern) + |> R.bind + (\( cpattern, bindings ) -> + Env.addLocals bindings env + |> R.bind + (\newEnv -> + verifyBindings W.Pattern bindings (canonicalize syntaxVersion newEnv expr) + |> R.fmap + (\( cexpr, freeLocals ) -> + ( Can.CaseBranch cpattern cexpr, freeLocals ) + ) + ) + ) + ) + + + +-- CANONICALIZE BINOPS + + +canonicalizeBinops : SyntaxVersion -> A.Region -> Env.Env -> List ( Src.Expr, A.Located Name.Name ) -> Src.Expr -> EResult FreeLocals (List W.Warning) Can.Expr +canonicalizeBinops syntaxVersion overallRegion env ops final = + let + canonicalizeHelp : ( Src.Expr, A.Located Name ) -> R.RResult FreeLocals (List W.Warning) Error.Error ( Can.Expr, Env.Binop ) + canonicalizeHelp ( expr, A.At region op ) = + R.fmap Tuple.pair (canonicalize syntaxVersion env expr) + |> R.apply (Env.findBinop region env op) + in + R.bind (runBinopStepper overallRegion) + (R.fmap More (R.traverse canonicalizeHelp ops) + |> R.apply (canonicalize syntaxVersion env final) + ) + + +type Step + = Done Can.Expr + | More (List ( Can.Expr, Env.Binop )) Can.Expr + | Error Env.Binop Env.Binop + + +runBinopStepper : A.Region -> Step -> EResult FreeLocals w Can.Expr +runBinopStepper overallRegion step = + case step of + Done expr -> + R.ok expr + + More [] expr -> + R.ok expr + + More (( expr, op ) :: rest) final -> + runBinopStepper overallRegion <| + toBinopStep (toBinop op expr) op rest final + + Error (Env.Binop op1 _ _ _ _ _) (Env.Binop op2 _ _ _ _ _) -> + R.throw (Error.Binop overallRegion op1 op2) + + +toBinopStep : (Can.Expr -> Can.Expr) -> Env.Binop -> List ( Can.Expr, Env.Binop ) -> Can.Expr -> Step +toBinopStep makeBinop ((Env.Binop _ _ _ _ rootAssociativity rootPrecedence) as rootOp) middle final = + case middle of + [] -> + Done (makeBinop final) + + ( expr, (Env.Binop _ _ _ _ associativity precedence) as op ) :: rest -> + if precedence < rootPrecedence then + More (( makeBinop expr, op ) :: rest) final + + else if precedence > rootPrecedence then + case toBinopStep (toBinop op expr) op rest final of + Done newLast -> + Done (makeBinop newLast) + + More newMiddle newLast -> + toBinopStep makeBinop rootOp newMiddle newLast + + Error a b -> + Error a b + + else + case ( rootAssociativity, associativity ) of + ( Binop.Left, Binop.Left ) -> + toBinopStep (toBinop op (makeBinop expr)) op rest final + + ( Binop.Right, Binop.Right ) -> + toBinopStep (makeBinop << toBinop op expr) op rest final + + _ -> + Error rootOp op + + +toBinop : Env.Binop -> Can.Expr -> Can.Expr -> Can.Expr +toBinop (Env.Binop op home name annotation _ _) left right = + A.merge left right (Can.Binop op home name annotation left right) + + +canonicalizeLet : SyntaxVersion -> A.Region -> Env.Env -> List (A.Located Src.Def) -> Src.Expr -> EResult FreeLocals (List W.Warning) Can.Expr +canonicalizeLet syntaxVersion letRegion env defs body = + directUsage <| + (Dups.detect (Error.DuplicatePattern Error.DPLetBinding) + (List.foldl addBindings Dups.none defs) + |> R.bind + (\bindings -> + Env.addLocals bindings env + |> R.bind + (\newEnv -> + verifyBindings W.Def bindings <| + (Utils.foldM (addDefNodes syntaxVersion newEnv) [] defs + |> R.bind + (\nodes -> + canonicalize syntaxVersion newEnv body + |> R.bind + (\cbody -> + detectCycles letRegion (Graph.stronglyConnComp nodes) cbody + ) + ) + ) + ) + ) + ) + + +addBindings : A.Located Src.Def -> Dups.Tracker A.Region -> Dups.Tracker A.Region +addBindings (A.At _ def) bindings = + case def of + Src.Define (A.At region name) _ _ _ -> + Dups.insert name region region bindings + + Src.Destruct pattern _ -> + addBindingsHelp bindings pattern + + +addBindingsHelp : Dups.Tracker A.Region -> Src.Pattern -> Dups.Tracker A.Region +addBindingsHelp bindings (A.At region pattern) = + case pattern of + Src.PAnything _ -> + bindings + + Src.PVar name -> + Dups.insert name region region bindings + + Src.PRecord ( _, fields ) -> + let + addField : Src.C2 (A.Located Name) -> Dups.Tracker A.Region -> Dups.Tracker A.Region + addField ( _, A.At fieldRegion name ) dict = + Dups.insert name fieldRegion fieldRegion dict + in + List.foldl addField bindings fields + + Src.PUnit _ -> + bindings + + Src.PTuple a b cs -> + List.foldl (flip addBindingsHelp) bindings (List.map Src.c2Value (a :: b :: cs)) + + Src.PCtor _ _ patterns -> + List.foldl (flip addBindingsHelp) bindings (List.map Src.c1Value patterns) + + Src.PCtorQual _ _ _ patterns -> + List.foldl (flip addBindingsHelp) bindings (List.map Src.c1Value patterns) + + Src.PList ( _, patterns ) -> + List.foldl (flip addBindingsHelp) bindings (List.map Src.c2Value patterns) + + Src.PCons ( _, hd ) ( _, tl ) -> + addBindingsHelp (addBindingsHelp bindings hd) tl + + Src.PAlias ( _, aliasPattern ) ( _, A.At nameRegion name ) -> + Dups.insert name nameRegion nameRegion <| + addBindingsHelp bindings aliasPattern + + Src.PChr _ -> + bindings + + Src.PStr _ _ -> + bindings + + Src.PInt _ _ -> + bindings + + Src.PParens ( _, parensPattern ) -> + addBindingsHelp bindings parensPattern + + +type alias Node = + ( Binding, Name.Name, List Name.Name ) + + +type Binding + = Define Can.Def + | Edge (A.Located Name.Name) + | Destruct Can.Pattern Can.Expr + + +addDefNodes : SyntaxVersion -> Env.Env -> List Node -> A.Located Src.Def -> EResult FreeLocals (List W.Warning) (List Node) +addDefNodes syntaxVersion env nodes (A.At _ def) = + case def of + Src.Define ((A.At _ name) as aname) srcArgs ( _, body ) maybeType -> + case maybeType of + Nothing -> + Pattern.verify (Error.DPFuncArgs name) + (R.traverse (Pattern.canonicalize syntaxVersion env) (List.map Src.c1Value srcArgs)) + |> R.bind + (\( args, argBindings ) -> + Env.addLocals argBindings env + |> R.bind + (\newEnv -> + verifyBindings W.Pattern argBindings (canonicalize syntaxVersion newEnv body) + |> R.bind + (\( cbody, freeLocals ) -> + let + cdef : Can.Def + cdef = + Can.Def aname args cbody + + node : ( Binding, Name, List Name ) + node = + ( Define cdef, name, Dict.keys compare freeLocals ) + in + logLetLocals args freeLocals (node :: nodes) + ) + ) + ) + + Just ( _, ( _, tipe ) ) -> + Type.toAnnotation syntaxVersion env tipe + |> R.bind + (\(Can.Forall freeVars ctipe) -> + Pattern.verify (Error.DPFuncArgs name) + (gatherTypedArgs syntaxVersion env name (List.map Src.c1Value srcArgs) ctipe Index.first []) + |> R.bind + (\( ( args, resultType ), argBindings ) -> + Env.addLocals argBindings env + |> R.bind + (\newEnv -> + verifyBindings W.Pattern argBindings (canonicalize syntaxVersion newEnv body) + |> R.bind + (\( cbody, freeLocals ) -> + let + cdef : Can.Def + cdef = + Can.TypedDef aname freeVars args cbody resultType + + node : ( Binding, Name, List Name ) + node = + ( Define cdef, name, Dict.keys compare freeLocals ) + in + logLetLocals args freeLocals (node :: nodes) + ) + ) + ) + ) + + Src.Destruct pattern ( _, body ) -> + Pattern.verify Error.DPDestruct + (Pattern.canonicalize syntaxVersion env pattern) + |> R.bind + (\( cpattern, _ ) -> + R.RResult + (\fs ws -> + case canonicalize syntaxVersion env body of + R.RResult k -> + case k Dict.empty ws of + R.ROk freeLocals warnings cbody -> + let + names : List (A.Located Name) + names = + getPatternNames [] pattern + + name : Name + name = + Name.fromManyNames (List.map A.toValue names) + + node : ( Binding, Name, List Name ) + node = + ( Destruct cpattern cbody, name, Dict.keys compare freeLocals ) + in + R.ROk + (Utils.mapUnionWith identity compare combineUses fs freeLocals) + warnings + (List.foldl (addEdge [ name ]) (node :: nodes) names) + + R.RErr freeLocals warnings errors -> + R.RErr (Utils.mapUnionWith identity compare combineUses freeLocals fs) warnings errors + ) + ) + + +logLetLocals : List arg -> FreeLocals -> value -> EResult FreeLocals w value +logLetLocals args letLocals value = + R.RResult + (\freeLocals warnings -> + R.ROk + (Utils.mapUnionWith identity + compare + combineUses + freeLocals + (case args of + [] -> + letLocals + + _ -> + Dict.map (\_ -> delayUse) letLocals + ) + ) + warnings + value + ) + + +addEdge : List Name.Name -> A.Located Name.Name -> List Node -> List Node +addEdge edges ((A.At _ name) as aname) nodes = + ( Edge aname, name, edges ) :: nodes + + +getPatternNames : List (A.Located Name.Name) -> Src.Pattern -> List (A.Located Name.Name) +getPatternNames names (A.At region pattern) = + case pattern of + Src.PAnything _ -> + names + + Src.PVar name -> + A.At region name :: names + + Src.PRecord ( _, fields ) -> + List.map Src.c2Value fields ++ names + + Src.PAlias ( _, ptrn ) ( _, name ) -> + getPatternNames (name :: names) ptrn + + Src.PUnit _ -> + names + + Src.PTuple ( _, a ) ( _, b ) cs -> + List.foldl (flip getPatternNames) (getPatternNames (getPatternNames names a) b) (List.map Src.c2Value cs) + + Src.PCtor _ _ args -> + List.foldl (flip getPatternNames) names (List.map Src.c1Value args) + + Src.PCtorQual _ _ _ args -> + List.foldl (flip getPatternNames) names (List.map Src.c1Value args) + + Src.PList ( _, patterns ) -> + List.foldl (flip getPatternNames) names (List.map Src.c2Value patterns) + + Src.PCons ( _, hd ) ( _, tl ) -> + getPatternNames (getPatternNames names hd) tl + + Src.PChr _ -> + names + + Src.PStr _ _ -> + names + + Src.PInt _ _ -> + names + + Src.PParens ( _, parensPattern ) -> + getPatternNames names parensPattern + + +gatherTypedArgs : + SyntaxVersion + -> Env.Env + -> Name.Name + -> List Src.Pattern + -> Can.Type + -> Index.ZeroBased + -> List ( Can.Pattern, Can.Type ) + -> EResult Pattern.DupsDict w ( List ( Can.Pattern, Can.Type ), Can.Type ) +gatherTypedArgs syntaxVersion env name srcArgs tipe index revTypedArgs = + case srcArgs of + [] -> + R.ok ( List.reverse revTypedArgs, tipe ) + + srcArg :: otherSrcArgs -> + case Type.iteratedDealias tipe of + Can.TLambda argType resultType -> + Pattern.canonicalize syntaxVersion env srcArg + |> R.bind + (\arg -> + gatherTypedArgs syntaxVersion env name otherSrcArgs resultType (Index.next index) <| + (( arg, argType ) :: revTypedArgs) + ) + + _ -> + let + ( A.At start _, A.At end _ ) = + ( Prelude.head srcArgs, Prelude.last srcArgs ) + in + R.throw (Error.AnnotationTooShort (A.mergeRegions start end) name index (List.length srcArgs)) + + +detectCycles : A.Region -> List (Graph.SCC Binding) -> Can.Expr -> EResult i w Can.Expr +detectCycles letRegion sccs body = + case sccs of + [] -> + R.ok body + + scc :: subSccs -> + case scc of + Graph.AcyclicSCC binding -> + case binding of + Define def -> + detectCycles letRegion subSccs body + |> R.fmap (Can.Let def) + |> R.fmap (A.At letRegion) + + Edge _ -> + detectCycles letRegion subSccs body + + Destruct pattern expr -> + detectCycles letRegion subSccs body + |> R.fmap (Can.LetDestruct pattern expr) + |> R.fmap (A.At letRegion) + + Graph.CyclicSCC bindings -> + R.fmap (A.At letRegion) + (R.fmap Can.LetRec (checkCycle bindings []) + |> R.apply (detectCycles letRegion subSccs body) + ) + + +checkCycle : List Binding -> List Can.Def -> EResult i w (List Can.Def) +checkCycle bindings defs = + case bindings of + [] -> + R.ok defs + + binding :: otherBindings -> + case binding of + Define ((Can.Def name args _) as def) -> + if List.isEmpty args then + R.throw (Error.RecursiveLet name (toNames otherBindings defs)) + + else + checkCycle otherBindings (def :: defs) + + Define ((Can.TypedDef name _ args _ _) as def) -> + if List.isEmpty args then + R.throw (Error.RecursiveLet name (toNames otherBindings defs)) + + else + checkCycle otherBindings (def :: defs) + + Edge name -> + R.throw (Error.RecursiveLet name (toNames otherBindings defs)) + + Destruct _ _ -> + -- a Destruct cannot appear in a cycle without any Edge values + -- so we just keep going until we get to the edges + checkCycle otherBindings defs + + +toNames : List Binding -> List Can.Def -> List Name.Name +toNames bindings revDefs = + case bindings of + [] -> + List.reverse (List.map getDefName revDefs) + + binding :: otherBindings -> + case binding of + Define def -> + getDefName def :: toNames otherBindings revDefs + + Edge (A.At _ name) -> + name :: toNames otherBindings revDefs + + Destruct _ _ -> + toNames otherBindings revDefs + + +getDefName : Can.Def -> Name.Name +getDefName def = + case def of + Can.Def (A.At _ name) _ _ -> + name + + Can.TypedDef (A.At _ name) _ _ _ _ -> + name + + +logVar : Name.Name -> a -> EResult FreeLocals w a +logVar name value = + R.RResult <| + \freeLocals warnings -> + R.ROk (Utils.mapInsertWith identity combineUses name oneDirectUse freeLocals) warnings value + + +oneDirectUse : Uses +oneDirectUse = + Uses + { direct = 1 + , delayed = 0 + } + + +combineUses : Uses -> Uses -> Uses +combineUses (Uses ab) (Uses xy) = + Uses + { direct = ab.direct + xy.direct + , delayed = ab.delayed + xy.delayed + } + + +delayUse : Uses -> Uses +delayUse (Uses { direct, delayed }) = + Uses + { direct = 0 + , delayed = direct + delayed + } + + + +-- MANAGING BINDINGS + + +verifyBindings : + W.Context + -> Pattern.Bindings + -> EResult FreeLocals (List W.Warning) value + -> EResult info (List W.Warning) ( value, FreeLocals ) +verifyBindings context bindings (R.RResult k) = + R.RResult + (\info warnings -> + case k Dict.empty warnings of + R.ROk freeLocals warnings1 value -> + let + outerFreeLocals : Dict String Name Uses + outerFreeLocals = + Dict.diff freeLocals bindings + + warnings2 : List W.Warning + warnings2 = + -- NOTE: Uses Map.size for O(1) lookup. This means there is + -- no dictionary allocation unless a problem is detected. + if Dict.size bindings + Dict.size outerFreeLocals == Dict.size freeLocals then + warnings1 + + else + Dict.foldl compare (addUnusedWarning context) warnings1 <| + Dict.diff bindings freeLocals + in + R.ROk info warnings2 ( value, outerFreeLocals ) + + R.RErr _ warnings1 err -> + R.RErr info warnings1 err + ) + + +addUnusedWarning : W.Context -> Name.Name -> A.Region -> List W.Warning -> List W.Warning +addUnusedWarning context name region warnings = + W.UnusedVariable region context name :: warnings + + +directUsage : EResult () w ( expr, FreeLocals ) -> EResult FreeLocals w expr +directUsage (R.RResult k) = + R.RResult + (\freeLocals warnings -> + case k () warnings of + R.ROk () ws ( value, newFreeLocals ) -> + R.ROk (Utils.mapUnionWith identity compare combineUses freeLocals newFreeLocals) ws value + + R.RErr () ws es -> + R.RErr freeLocals ws es + ) + + +delayedUsage : EResult () w ( expr, FreeLocals ) -> EResult FreeLocals w expr +delayedUsage (R.RResult k) = + R.RResult + (\freeLocals warnings -> + case k () warnings of + R.ROk () ws ( value, newFreeLocals ) -> + let + delayedLocals : Dict String Name Uses + delayedLocals = + Dict.map (\_ -> delayUse) newFreeLocals + in + R.ROk (Utils.mapUnionWith identity compare combineUses freeLocals delayedLocals) ws value + + R.RErr () ws es -> + R.RErr freeLocals ws es + ) + + + +-- FIND VARIABLE + + +findVar : A.Region -> Env.Env -> Name -> EResult FreeLocals w Can.Expr_ +findVar region env name = + case Dict.get identity name env.vars of + Just var -> + case var of + Env.Local _ -> + logVar name (Can.VarLocal name) + + Env.TopLevel _ -> + logVar name (Can.VarTopLevel env.home name) + + Env.Foreign home annotation -> + R.ok + (if home == ModuleName.debug then + Can.VarDebug env.home name annotation + + else + Can.VarForeign home name annotation + ) + + Env.Foreigns h hs -> + R.throw (Error.AmbiguousVar region Nothing name h hs) + + Nothing -> + R.throw (Error.NotFoundVar region Nothing name (toPossibleNames env.vars env.q_vars)) + + +findVarQual : A.Region -> Env.Env -> Name -> Name -> EResult FreeLocals w Can.Expr_ +findVarQual region env prefix name = + case Dict.get identity prefix env.q_vars of + Just qualified -> + case Dict.get identity name qualified of + Just (Env.Specific home annotation) -> + R.ok <| + if home == ModuleName.debug then + Can.VarDebug env.home name annotation + + else + Can.VarForeign home name annotation + + Just (Env.Ambiguous h hs) -> + R.throw (Error.AmbiguousVar region (Just prefix) name h hs) + + Nothing -> + R.throw (Error.NotFoundVar region (Just prefix) name (toPossibleNames env.vars env.q_vars)) + + Nothing -> + let + (IO.Canonical pkg _) = + env.home + in + if Name.isKernel prefix && Pkg.isKernel pkg then + R.ok <| Can.VarKernel (Name.getKernel prefix) name + + else + R.throw (Error.NotFoundVar region (Just prefix) name (toPossibleNames env.vars env.q_vars)) + + +toPossibleNames : Dict String Name Env.Var -> Env.Qualified Can.Annotation -> Error.PossibleNames +toPossibleNames exposed qualified = + Error.PossibleNames (Utils.keysSet identity compare exposed) (Dict.map (\_ -> Utils.keysSet identity compare) qualified) + + + +-- FIND CTOR + + +toVarCtor : Name -> Env.Ctor -> Can.Expr_ +toVarCtor name ctor = + case ctor of + Env.Ctor home typeName (Can.Union vars _ _ opts) index args -> + let + freeVars : Dict String Name () + freeVars = + Dict.fromList identity (List.map (\v -> ( v, () )) vars) + + result : Can.Type + result = + Can.TType home typeName (List.map Can.TVar vars) + + tipe : Can.Type + tipe = + List.foldr Can.TLambda result args + in + Can.VarCtor opts home name index (Can.Forall freeVars tipe) + + Env.RecordCtor home vars tipe -> + let + freeVars : Dict String Name () + freeVars = + Dict.fromList identity (List.map (\v -> ( v, () )) vars) + in + Can.VarCtor Can.Normal home name Index.first (Can.Forall freeVars tipe) diff --git a/src/Compiler/Canonicalize/Module.elm b/src/Compiler/Canonicalize/Module.elm new file mode 100644 index 0000000000..d226c68d5c --- /dev/null +++ b/src/Compiler/Canonicalize/Module.elm @@ -0,0 +1,354 @@ +module Compiler.Canonicalize.Module exposing (MResult, canonicalize) + +import Compiler.AST.Canonical as Can +import Compiler.AST.Source as Src +import Compiler.Canonicalize.Effects as Effects +import Compiler.Canonicalize.Environment as Env +import Compiler.Canonicalize.Environment.Dups as Dups +import Compiler.Canonicalize.Environment.Foreign as Foreign +import Compiler.Canonicalize.Environment.Local as Local +import Compiler.Canonicalize.Expression as Expr +import Compiler.Canonicalize.Pattern as Pattern +import Compiler.Canonicalize.Type as Type +import Compiler.Data.Index as Index +import Compiler.Data.Name as Name exposing (Name) +import Compiler.Elm.Interface as I +import Compiler.Elm.ModuleName as ModuleName +import Compiler.Elm.Package as Pkg +import Compiler.Parse.SyntaxVersion exposing (SyntaxVersion) +import Compiler.Reporting.Annotation as A +import Compiler.Reporting.Error.Canonicalize as Error +import Compiler.Reporting.Result as R +import Compiler.Reporting.Warning as W +import Data.Graph as Graph +import Data.Map as Dict exposing (Dict) +import System.TypeCheck.IO as IO +import Utils.Crash exposing (crash) + + + +-- RESULT + + +type alias MResult i w a = + R.RResult i w Error.Error a + + + +-- MODULES + + +canonicalize : Pkg.Name -> Dict String ModuleName.Raw I.Interface -> Src.Module -> MResult i (List W.Warning) Can.Module +canonicalize pkg ifaces ((Src.Module syntaxVersion _ exports docs imports values _ _ binops effects) as modul) = + let + home : IO.Canonical + home = + IO.Canonical pkg (Src.getName modul) + + cbinops : Dict String Name Can.Binop + cbinops = + Dict.fromList identity (List.map canonicalizeBinop binops) + in + Foreign.createInitialEnv home ifaces imports + |> R.bind (Local.add modul) + |> R.bind + (\( env, cunions, caliases ) -> + canonicalizeValues syntaxVersion env values + |> R.bind + (\cvalues -> + Effects.canonicalize syntaxVersion env values cunions effects + |> R.bind + (\ceffects -> + canonicalizeExports values cunions caliases cbinops ceffects exports + |> R.fmap + (\cexports -> + Can.Module home cexports docs cvalues cunions caliases cbinops ceffects + ) + ) + ) + ) + + + +-- CANONICALIZE BINOP + + +canonicalizeBinop : A.Located Src.Infix -> ( Name, Can.Binop ) +canonicalizeBinop (A.At _ (Src.Infix ( _, op ) ( _, associativity ) ( _, precedence ) ( _, func ))) = + ( op, Can.Binop_ associativity precedence func ) + + + +-- DECLARATIONS / CYCLE DETECTION +-- +-- There are two phases of cycle detection: +-- +-- 1. Detect cycles using ALL dependencies => needed for type inference +-- 2. Detect cycles using DIRECT dependencies => nonterminating recursion +-- + + +canonicalizeValues : SyntaxVersion -> Env.Env -> List (A.Located Src.Value) -> MResult i (List W.Warning) Can.Decls +canonicalizeValues syntaxVersion env values = + R.traverse (toNodeOne syntaxVersion env) values + |> R.bind (\nodes -> detectCycles (Graph.stronglyConnComp nodes)) + + +detectCycles : List (Graph.SCC NodeTwo) -> MResult i w Can.Decls +detectCycles sccs = + case sccs of + [] -> + R.ok Can.SaveTheEnvironment + + scc :: otherSccs -> + case scc of + Graph.AcyclicSCC ( def, _, _ ) -> + R.fmap (Can.Declare def) (detectCycles otherSccs) + + Graph.CyclicSCC subNodes -> + R.traverse detectBadCycles (Graph.stronglyConnComp subNodes) + |> R.bind + (\defs -> + case defs of + [] -> + detectCycles otherSccs + + d :: ds -> + R.fmap (Can.DeclareRec d ds) (detectCycles otherSccs) + ) + + +detectBadCycles : Graph.SCC Can.Def -> MResult i w Can.Def +detectBadCycles scc = + case scc of + Graph.AcyclicSCC def -> + R.ok def + + Graph.CyclicSCC [] -> + crash "The definition of Data.Graph.SCC should not allow empty CyclicSCC!" + + Graph.CyclicSCC (def :: defs) -> + let + (A.At region name) = + extractDefName def + + names : List Name + names = + List.map (A.toValue << extractDefName) defs + in + R.throw (Error.RecursiveDecl region name names) + + +extractDefName : Can.Def -> A.Located Name +extractDefName def = + case def of + Can.Def name _ _ -> + name + + Can.TypedDef name _ _ _ _ -> + name + + + +-- DECLARATIONS / CYCLE DETECTION SETUP +-- +-- toNodeOne and toNodeTwo set up nodes for the two cycle detection phases. +-- +-- Phase one nodes track ALL dependencies. +-- This allows us to find cyclic values for type inference. + + +type alias NodeOne = + ( NodeTwo, Name.Name, List Name.Name ) + + + +-- Phase two nodes track DIRECT dependencies. +-- This allows us to detect cycles that definitely do not terminate. + + +type alias NodeTwo = + ( Can.Def, Name, List Name ) + + +toNodeOne : SyntaxVersion -> Env.Env -> A.Located Src.Value -> MResult i (List W.Warning) NodeOne +toNodeOne syntaxVersion env (A.At _ (Src.Value _ ( _, (A.At _ name) as aname ) srcArgs ( _, body ) maybeType)) = + case maybeType of + Nothing -> + Pattern.verify (Error.DPFuncArgs name) + (R.traverse (Pattern.canonicalize syntaxVersion env) (List.map Src.c1Value srcArgs)) + |> R.bind + (\( args, argBindings ) -> + Env.addLocals argBindings env + |> R.bind + (\newEnv -> + Expr.verifyBindings W.Pattern argBindings (Expr.canonicalize syntaxVersion newEnv body) + |> R.fmap + (\( cbody, freeLocals ) -> + let + def : Can.Def + def = + Can.Def aname args cbody + in + ( toNodeTwo name srcArgs def freeLocals + , name + , Dict.keys compare freeLocals + ) + ) + ) + ) + + Just ( _, ( _, srcType ) ) -> + Type.toAnnotation syntaxVersion env srcType + |> R.bind + (\(Can.Forall freeVars tipe) -> + Pattern.verify (Error.DPFuncArgs name) + (Expr.gatherTypedArgs syntaxVersion env name (List.map Src.c1Value srcArgs) tipe Index.first []) + |> R.bind + (\( ( args, resultType ), argBindings ) -> + Env.addLocals argBindings env + |> R.bind + (\newEnv -> + Expr.verifyBindings W.Pattern argBindings (Expr.canonicalize syntaxVersion newEnv body) + |> R.fmap + (\( cbody, freeLocals ) -> + let + def : Can.Def + def = + Can.TypedDef aname freeVars args cbody resultType + in + ( toNodeTwo name srcArgs def freeLocals + , name + , Dict.keys compare freeLocals + ) + ) + ) + ) + ) + + +toNodeTwo : Name -> List arg -> Can.Def -> Expr.FreeLocals -> NodeTwo +toNodeTwo name args def freeLocals = + case args of + [] -> + ( def, name, Dict.foldr compare addDirects [] freeLocals ) + + _ -> + ( def, name, [] ) + + +addDirects : Name -> Expr.Uses -> List Name -> List Name +addDirects name (Expr.Uses { direct }) directDeps = + if direct > 0 then + name :: directDeps + + else + directDeps + + + +-- CANONICALIZE EXPORTS + + +canonicalizeExports : + List (A.Located Src.Value) + -> Dict String Name union + -> Dict String Name alias + -> Dict String Name binop + -> Can.Effects + -> A.Located Src.Exposing + -> MResult i w Can.Exports +canonicalizeExports values unions aliases binops effects (A.At region exposing_) = + case exposing_ of + Src.Open _ _ -> + R.ok (Can.ExportEverything region) + + Src.Explicit (A.At _ exposeds) -> + let + names : Dict String Name () + names = + Dict.fromList identity (List.map valueToName values) + in + R.traverse (checkExposed names unions aliases binops effects) (List.map Src.c2Value exposeds) + |> R.bind + (\infos -> + Dups.detect Error.ExportDuplicate (Dups.unions infos) + |> R.fmap Can.Export + ) + + +valueToName : A.Located Src.Value -> ( Name, () ) +valueToName (A.At _ (Src.Value _ ( _, A.At _ name ) _ _ _)) = + ( name, () ) + + +checkExposed : + Dict String Name value + -> Dict String Name union + -> Dict String Name alias + -> Dict String Name binop + -> Can.Effects + -> Src.Exposed + -> MResult i w (Dups.Tracker (A.Located Can.Export)) +checkExposed values unions aliases binops effects exposed = + case exposed of + Src.Lower (A.At region name) -> + if Dict.member identity name values then + ok name region Can.ExportValue + + else + case checkPorts effects name of + Nothing -> + ok name region Can.ExportPort + + Just ports -> + R.throw (Error.ExportNotFound region Error.BadVar name (ports ++ Dict.keys compare values)) + + Src.Operator region name -> + if Dict.member identity name binops then + ok name region Can.ExportBinop + + else + R.throw (Error.ExportNotFound region Error.BadOp name (Dict.keys compare binops)) + + Src.Upper (A.At region name) ( _, Src.Public dotDotRegion ) -> + if Dict.member identity name unions then + ok name region Can.ExportUnionOpen + + else if Dict.member identity name aliases then + R.throw (Error.ExportOpenAlias dotDotRegion name) + + else + R.throw (Error.ExportNotFound region Error.BadType name (Dict.keys compare unions ++ Dict.keys compare aliases)) + + Src.Upper (A.At region name) ( _, Src.Private ) -> + if Dict.member identity name unions then + ok name region Can.ExportUnionClosed + + else if Dict.member identity name aliases then + ok name region Can.ExportAlias + + else + R.throw (Error.ExportNotFound region Error.BadType name (Dict.keys compare unions ++ Dict.keys compare aliases)) + + +checkPorts : Can.Effects -> Name -> Maybe (List Name) +checkPorts effects name = + case effects of + Can.NoEffects -> + Just [] + + Can.Ports ports -> + if Dict.member identity name ports then + Nothing + + else + Just (Dict.keys compare ports) + + Can.Manager _ _ _ _ -> + Just [] + + +ok : Name -> A.Region -> Can.Export -> MResult i w (Dups.Tracker (A.Located Can.Export)) +ok name region export = + R.ok (Dups.one name region (A.At region export)) diff --git a/src/Compiler/Canonicalize/Pattern.elm b/src/Compiler/Canonicalize/Pattern.elm new file mode 100644 index 0000000000..5d638ddf76 --- /dev/null +++ b/src/Compiler/Canonicalize/Pattern.elm @@ -0,0 +1,215 @@ +module Compiler.Canonicalize.Pattern exposing + ( Bindings + , DupsDict + , PResult + , canonicalize + , verify + ) + +import Compiler.AST.Canonical as Can +import Compiler.AST.Source as Src +import Compiler.Canonicalize.Environment as Env +import Compiler.Canonicalize.Environment.Dups as Dups +import Compiler.Data.Index as Index +import Compiler.Data.Name as Name +import Compiler.Elm.ModuleName as ModuleName +import Compiler.Parse.SyntaxVersion as SV exposing (SyntaxVersion) +import Compiler.Reporting.Annotation as A +import Compiler.Reporting.Error.Canonicalize as Error +import Compiler.Reporting.Result as R +import Data.Map exposing (Dict) +import Utils.Main as Utils + + + +-- RESULTS + + +type alias PResult i w a = + R.RResult i w Error.Error a + + +type alias Bindings = + Dict String Name.Name A.Region + + + +-- VERIFY + + +verify : Error.DuplicatePatternContext -> PResult DupsDict w a -> PResult i w ( a, Bindings ) +verify context (R.RResult k) = + R.RResult <| + \info warnings -> + case k Dups.none warnings of + R.RErr _ warnings1 errors -> + R.RErr info warnings1 errors + + R.ROk bindings warnings1 value -> + case Dups.detect (Error.DuplicatePattern context) bindings of + R.RResult k1 -> + case k1 () () of + R.RErr () () errs -> + R.RErr info warnings1 errs + + R.ROk () () dict -> + R.ROk info warnings1 ( value, dict ) + + + +-- CANONICALIZE + + +type alias DupsDict = + Dups.Tracker A.Region + + +canonicalize : SyntaxVersion -> Env.Env -> Src.Pattern -> PResult DupsDict w Can.Pattern +canonicalize syntaxVersion env (A.At region pattern) = + case pattern of + Src.PAnything _ -> + R.ok Can.PAnything + |> R.fmap (A.At region) + + Src.PVar name -> + logVar name region (Can.PVar name) + |> R.fmap (A.At region) + + Src.PRecord ( _, c2Fields ) -> + let + fields : List (A.Located Name.Name) + fields = + List.map Src.c2Value c2Fields + in + logFields fields (Can.PRecord (List.map A.toValue fields)) + |> R.fmap (A.At region) + + Src.PUnit _ -> + R.ok Can.PUnit + |> R.fmap (A.At region) + + Src.PTuple ( _, a ) ( _, b ) cs -> + R.fmap Can.PTuple (canonicalize syntaxVersion env a) + |> R.apply (canonicalize syntaxVersion env b) + |> R.apply (canonicalizeTuple syntaxVersion region env (List.map Src.c2Value cs)) + |> R.fmap (A.At region) + + Src.PCtor nameRegion name patterns -> + Env.findCtor nameRegion env name + |> R.bind (canonicalizeCtor syntaxVersion env region name (List.map Src.c1Value patterns)) + |> R.fmap (A.At region) + + Src.PCtorQual nameRegion home name patterns -> + Env.findCtorQual nameRegion env home name + |> R.bind (canonicalizeCtor syntaxVersion env region name (List.map Src.c1Value patterns)) + |> R.fmap (A.At region) + + Src.PList ( _, patterns ) -> + R.fmap Can.PList (canonicalizeList syntaxVersion env (List.map Src.c2Value patterns)) + |> R.fmap (A.At region) + + Src.PCons ( _, first ) ( _, rest ) -> + R.fmap Can.PCons (canonicalize syntaxVersion env first) + |> R.apply (canonicalize syntaxVersion env rest) + |> R.fmap (A.At region) + + Src.PAlias ( _, ptrn ) ( _, A.At reg name ) -> + canonicalize syntaxVersion env ptrn + |> R.bind (\cpattern -> logVar name reg (Can.PAlias cpattern name)) + |> R.fmap (A.At region) + + Src.PChr chr -> + R.ok (Can.PChr chr) + |> R.fmap (A.At region) + + Src.PStr str multiline -> + R.ok (Can.PStr str multiline) + |> R.fmap (A.At region) + + Src.PInt int _ -> + R.ok (Can.PInt int) + |> R.fmap (A.At region) + + Src.PParens ( _, pattern_ ) -> + canonicalize syntaxVersion env pattern_ + + +canonicalizeCtor : SyntaxVersion -> Env.Env -> A.Region -> Name.Name -> List Src.Pattern -> Env.Ctor -> PResult DupsDict w Can.Pattern_ +canonicalizeCtor syntaxVersion env region name patterns ctor = + case ctor of + Env.Ctor home tipe union index args -> + let + toCanonicalArg : Index.ZeroBased -> Src.Pattern -> Can.Type -> R.RResult DupsDict w Error.Error Can.PatternCtorArg + toCanonicalArg argIndex argPattern argTipe = + R.fmap (Can.PatternCtorArg argIndex argTipe) + (canonicalize syntaxVersion env argPattern) + in + Utils.indexedZipWithA toCanonicalArg patterns args + |> R.bind + (\verifiedList -> + case verifiedList of + Index.LengthMatch cargs -> + if tipe == Name.bool && home == ModuleName.basics then + R.ok (Can.PBool union (name == Name.true)) + + else + R.ok (Can.PCtor { home = home, type_ = tipe, union = union, name = name, index = index, args = cargs }) + + Index.LengthMismatch actualLength expectedLength -> + R.throw (Error.BadArity region Error.PatternArity name expectedLength actualLength) + ) + + Env.RecordCtor _ _ _ -> + R.throw (Error.PatternHasRecordCtor region name) + + +canonicalizeTuple : SyntaxVersion -> A.Region -> Env.Env -> List Src.Pattern -> PResult DupsDict w (List Can.Pattern) +canonicalizeTuple syntaxVersion tupleRegion env extras = + case extras of + [] -> + R.ok [] + + [ three ] -> + R.fmap List.singleton (canonicalize syntaxVersion env three) + + _ -> + case syntaxVersion of + SV.Elm -> + R.throw (Error.TupleLargerThanThree tupleRegion) + + SV.Guida -> + R.traverse (canonicalize syntaxVersion env) extras + + +canonicalizeList : SyntaxVersion -> Env.Env -> List Src.Pattern -> PResult DupsDict w (List Can.Pattern) +canonicalizeList syntaxVersion env list = + case list of + [] -> + R.ok [] + + pattern :: otherPatterns -> + R.fmap (::) (canonicalize syntaxVersion env pattern) + |> R.apply (canonicalizeList syntaxVersion env otherPatterns) + + + +-- LOG BINDINGS + + +logVar : Name.Name -> A.Region -> a -> PResult DupsDict w a +logVar name region value = + R.RResult <| + \bindings warnings -> + R.ROk (Dups.insert name region region bindings) warnings value + + +logFields : List (A.Located Name.Name) -> a -> PResult DupsDict w a +logFields fields value = + let + addField : A.Located Name.Name -> Dups.Tracker A.Region -> Dups.Tracker A.Region + addField (A.At region name) dict = + Dups.insert name region region dict + in + R.RResult <| + \bindings warnings -> + R.ROk (List.foldl addField bindings fields) warnings value diff --git a/src/Compiler/Canonicalize/Type.elm b/src/Compiler/Canonicalize/Type.elm new file mode 100644 index 0000000000..aa64e4cc89 --- /dev/null +++ b/src/Compiler/Canonicalize/Type.elm @@ -0,0 +1,172 @@ +module Compiler.Canonicalize.Type exposing + ( CResult + , canonicalize + , toAnnotation + ) + +import Basics.Extra exposing (flip) +import Compiler.AST.Canonical as Can +import Compiler.AST.Source as Src +import Compiler.Canonicalize.Environment as Env +import Compiler.Canonicalize.Environment.Dups as Dups +import Compiler.Data.Name as Name +import Compiler.Parse.SyntaxVersion as SV exposing (SyntaxVersion) +import Compiler.Reporting.Annotation as A +import Compiler.Reporting.Error.Canonicalize as Error +import Compiler.Reporting.Result as R +import Data.Map as Dict exposing (Dict) +import Utils.Main as Utils + + + +-- RESULT + + +type alias CResult i w a = + R.RResult i w Error.Error a + + + +-- TO ANNOTATION + + +toAnnotation : SyntaxVersion -> Env.Env -> Src.Type -> CResult i w Can.Annotation +toAnnotation syntaxVersion env srcType = + canonicalize syntaxVersion env srcType + |> R.bind (\tipe -> R.ok (Can.Forall (addFreeVars Dict.empty tipe) tipe)) + + + +-- CANONICALIZE TYPES + + +canonicalize : SyntaxVersion -> Env.Env -> Src.Type -> CResult i w Can.Type +canonicalize syntaxVersion env (A.At typeRegion tipe) = + case tipe of + Src.TVar x -> + R.ok (Can.TVar x) + + Src.TType region name args -> + Env.findType region env name + |> R.bind (canonicalizeType syntaxVersion env typeRegion name (List.map Tuple.second args)) + + Src.TTypeQual region home name args -> + Env.findTypeQual region env home name + |> R.bind (canonicalizeType syntaxVersion env typeRegion name (List.map Tuple.second args)) + + Src.TLambda ( _, a ) ( _, b ) -> + R.fmap Can.TLambda (canonicalize syntaxVersion env a) + |> R.apply (canonicalize syntaxVersion env b) + + Src.TRecord fields maybeExt _ -> + Dups.checkFields (canonicalizeFields syntaxVersion env fields) + |> R.bind (Utils.sequenceADict identity compare) + |> R.fmap (\cfields -> Can.TRecord cfields (Maybe.map (\( _, A.At _ ext ) -> ext) maybeExt)) + + Src.TUnit -> + R.ok Can.TUnit + + Src.TTuple ( _, a ) ( _, b ) cs -> + R.fmap Can.TTuple (canonicalize syntaxVersion env a) + |> R.apply (canonicalize syntaxVersion env b) + |> R.apply + (case cs of + [] -> + R.ok [] + + [ ( _, c ) ] -> + canonicalize syntaxVersion env c + |> R.fmap List.singleton + + _ -> + case syntaxVersion of + SV.Elm -> + R.throw (Error.TupleLargerThanThree typeRegion) + + SV.Guida -> + R.traverse (canonicalize syntaxVersion env) (List.map Src.c2EolValue cs) + ) + + Src.TParens ( _, tipe_ ) -> + canonicalize syntaxVersion env tipe_ + + +canonicalizeFields : SyntaxVersion -> Env.Env -> List (Src.C2 ( Src.C1 (A.Located Name.Name), Src.C1 Src.Type )) -> List ( A.Located Name.Name, CResult i w Can.FieldType ) +canonicalizeFields syntaxVersion env fields = + let + canonicalizeField : Int -> Src.C2 ( Src.C1 a, Src.C1 Src.Type ) -> ( a, R.RResult i w Error.Error Can.FieldType ) + canonicalizeField index ( _, ( ( _, name ), ( _, srcType ) ) ) = + ( name, R.fmap (Can.FieldType index) (canonicalize syntaxVersion env srcType) ) + in + List.indexedMap canonicalizeField fields + + + +-- CANONICALIZE TYPE + + +canonicalizeType : SyntaxVersion -> Env.Env -> A.Region -> Name.Name -> List Src.Type -> Env.Type -> CResult i w Can.Type +canonicalizeType syntaxVersion env region name args info = + R.traverse (canonicalize syntaxVersion env) args + |> R.bind + (\cargs -> + case info of + Env.Alias arity home argNames aliasedType -> + checkArity arity region name args <| + Can.TAlias home name (List.map2 Tuple.pair argNames cargs) (Can.Holey aliasedType) + + Env.Union arity home -> + checkArity arity region name args <| + Can.TType home name cargs + ) + + +checkArity : Int -> A.Region -> Name.Name -> List (A.Located arg) -> answer -> CResult i w answer +checkArity expected region name args answer = + let + actual : Int + actual = + List.length args + in + if expected == actual then + R.ok answer + + else + R.throw (Error.BadArity region Error.TypeArity name expected actual) + + + +-- ADD FREE VARS + + +addFreeVars : Dict String Name.Name () -> Can.Type -> Dict String Name.Name () +addFreeVars freeVars tipe = + case tipe of + Can.TLambda arg result -> + addFreeVars (addFreeVars freeVars result) arg + + Can.TVar var -> + Dict.insert identity var () freeVars + + Can.TType _ _ args -> + List.foldl (\b c -> addFreeVars c b) freeVars args + + Can.TRecord fields Nothing -> + Dict.foldl compare (\_ b c -> addFieldFreeVars c b) freeVars fields + + Can.TRecord fields (Just ext) -> + Dict.foldl compare (\_ b c -> addFieldFreeVars c b) (Dict.insert identity ext () freeVars) fields + + Can.TUnit -> + freeVars + + Can.TTuple a b cs -> + List.foldl (flip addFreeVars) (addFreeVars (addFreeVars freeVars a) b) cs + + Can.TAlias _ _ args _ -> + List.foldl (\( _, arg ) fvs -> addFreeVars fvs arg) freeVars args + + +addFieldFreeVars : Dict String Name.Name () -> Can.FieldType -> Dict String Name.Name () +addFieldFreeVars freeVars (Can.FieldType _ tipe) = + addFreeVars freeVars tipe diff --git a/src/Compiler/Compile.elm b/src/Compiler/Compile.elm new file mode 100644 index 0000000000..b45bb756e1 --- /dev/null +++ b/src/Compiler/Compile.elm @@ -0,0 +1,97 @@ +module Compiler.Compile exposing + ( Artifacts(..) + , compile + ) + +import Compiler.AST.Canonical as Can +import Compiler.AST.Optimized as Opt +import Compiler.AST.Source as Src +import Compiler.Canonicalize.Module as Canonicalize +import Compiler.Data.Name as Name exposing (Name) +import Compiler.Elm.Interface as I +import Compiler.Elm.ModuleName as ModuleName +import Compiler.Elm.Package as Pkg +import Compiler.Nitpick.PatternMatches as PatternMatches +import Compiler.Optimize.Module as Optimize +import Compiler.Reporting.Error as E +import Compiler.Reporting.Render.Type.Localizer as Localizer +import Compiler.Reporting.Result as R +import Compiler.Type.Constrain.Module as Type +import Compiler.Type.Solve as Type +import Data.Map exposing (Dict) +import System.TypeCheck.IO as TypeCheck +import Task exposing (Task) +import Utils.Task.Extra as Task + + + +-- COMPILE + + +type Artifacts + = Artifacts Can.Module (Dict String Name Can.Annotation) Opt.LocalGraph + + +compile : Pkg.Name -> Dict String ModuleName.Raw I.Interface -> Src.Module -> Task Never (Result E.Error Artifacts) +compile pkg ifaces modul = + Task.pure (canonicalize pkg ifaces modul) + |> Task.fmap + (\canonicalResult -> + case canonicalResult of + Ok canonical -> + Result.map2 (\annotations () -> annotations) + (typeCheck modul canonical) + (nitpick canonical) + |> Result.andThen + (\annotations -> + optimize modul annotations canonical + |> Result.map (\objects -> Artifacts canonical annotations objects) + ) + + Err err -> + Err err + ) + + + +-- PHASES + + +canonicalize : Pkg.Name -> Dict String ModuleName.Raw I.Interface -> Src.Module -> Result E.Error Can.Module +canonicalize pkg ifaces modul = + case Tuple.second (R.run (Canonicalize.canonicalize pkg ifaces modul)) of + Ok canonical -> + Ok canonical + + Err errors -> + Err (E.BadNames errors) + + +typeCheck : Src.Module -> Can.Module -> Result E.Error (Dict String Name Can.Annotation) +typeCheck modul canonical = + case TypeCheck.unsafePerformIO (TypeCheck.bind Type.run (Type.constrain canonical)) of + Ok annotations -> + Ok annotations + + Err errors -> + Err (E.BadTypes (Localizer.fromModule modul) errors) + + +nitpick : Can.Module -> Result E.Error () +nitpick canonical = + case PatternMatches.check canonical of + Ok () -> + Ok () + + Err errors -> + Err (E.BadPatterns errors) + + +optimize : Src.Module -> Dict String Name.Name Can.Annotation -> Can.Module -> Result E.Error Opt.LocalGraph +optimize modul annotations canonical = + case Tuple.second (R.run (Optimize.optimize annotations canonical)) of + Ok localGraph -> + Ok localGraph + + Err errors -> + Err (E.BadMains (Localizer.fromModule modul) errors) diff --git a/src/Compiler/Data/Bag.elm b/src/Compiler/Data/Bag.elm new file mode 100644 index 0000000000..c4513e32ae --- /dev/null +++ b/src/Compiler/Data/Bag.elm @@ -0,0 +1,64 @@ +module Compiler.Data.Bag exposing + ( Bag(..) + , append + , empty + , one + , toList + ) + +-- BAGS + + +type Bag a + = Empty + | One a + | Two (Bag a) (Bag a) + + + +-- HELPERS + + +empty : Bag a +empty = + Empty + + +one : a -> Bag a +one = + One + + +append : Bag a -> Bag a -> Bag a +append left right = + case ( left, right ) of + ( other, Empty ) -> + other + + ( Empty, other ) -> + other + + _ -> + Two left right + + + +-- TO LIST + + +toList : Bag a -> List a +toList bag = + toListHelp bag [] + + +toListHelp : Bag a -> List a -> List a +toListHelp bag list = + case bag of + Empty -> + list + + One x -> + x :: list + + Two a b -> + toListHelp a (toListHelp b list) diff --git a/src/Compiler/Data/Index.elm b/src/Compiler/Data/Index.elm new file mode 100644 index 0000000000..6afa73b320 --- /dev/null +++ b/src/Compiler/Data/Index.elm @@ -0,0 +1,113 @@ +module Compiler.Data.Index exposing + ( VerifiedList(..) + , ZeroBased + , first + , indexedMap + , indexedZipWith + , next + , second + , third + , toHuman + , toMachine + , zeroBasedDecoder + , zeroBasedEncoder + ) + +import Utils.Bytes.Decode as BD +import Utils.Bytes.Encode as BE + + + +-- ZERO BASED + + +type ZeroBased + = ZeroBased Int + + +first : ZeroBased +first = + ZeroBased 0 + + +second : ZeroBased +second = + ZeroBased 1 + + +third : ZeroBased +third = + ZeroBased 2 + + +next : ZeroBased -> ZeroBased +next (ZeroBased i) = + ZeroBased (i + 1) + + + +-- DESTRUCT + + +toMachine : ZeroBased -> Int +toMachine (ZeroBased index) = + index + + +toHuman : ZeroBased -> Int +toHuman (ZeroBased index) = + index + 1 + + + +-- INDEXED MAP + + +indexedMap : (ZeroBased -> a -> b) -> List a -> List b +indexedMap func xs = + List.map2 func (List.map ZeroBased (List.range 0 (List.length xs - 1))) xs + + +{-| indexedTraverse and indexedForA are defined on `Utils` +-} + + + +-- VERIFIED/INDEXED ZIP + + +type VerifiedList a + = LengthMatch (List a) + | LengthMismatch Int Int + + +indexedZipWith : (ZeroBased -> a -> b -> c) -> List a -> List b -> VerifiedList c +indexedZipWith func listX listY = + indexedZipWithHelp func 0 listX listY [] + + +indexedZipWithHelp : (ZeroBased -> a -> b -> c) -> Int -> List a -> List b -> List c -> VerifiedList c +indexedZipWithHelp func index listX listY revListZ = + case ( listX, listY ) of + ( [], [] ) -> + LengthMatch (List.reverse revListZ) + + ( x :: xs, y :: ys ) -> + indexedZipWithHelp func (index + 1) xs ys (func (ZeroBased index) x y :: revListZ) + + _ -> + LengthMismatch (index + List.length listX) (index + List.length listY) + + + +-- ENCODERS and DECODERS + + +zeroBasedEncoder : ZeroBased -> BE.Encoder +zeroBasedEncoder (ZeroBased zeroBased) = + BE.int zeroBased + + +zeroBasedDecoder : BD.Decoder ZeroBased +zeroBasedDecoder = + BD.map ZeroBased BD.int diff --git a/src/Compiler/Data/Map/Utils.elm b/src/Compiler/Data/Map/Utils.elm new file mode 100644 index 0000000000..52b3ebc918 --- /dev/null +++ b/src/Compiler/Data/Map/Utils.elm @@ -0,0 +1,33 @@ +module Compiler.Data.Map.Utils exposing + ( any + , fromKeys + , fromKeysA + ) + +import Data.Map as Dict exposing (Dict) +import Task exposing (Task) +import Utils.Main as Utils +import Utils.Task.Extra as Task + + + +-- FROM KEYS + + +fromKeys : (comparable -> v) -> List comparable -> Dict comparable comparable v +fromKeys toValue keys = + Dict.fromList identity (List.map (\k -> ( k, toValue k )) keys) + + +fromKeysA : (k -> comparable) -> (k -> Task Never v) -> List k -> Task Never (Dict comparable k v) +fromKeysA toComparable toValue keys = + Task.fmap (Dict.fromList toComparable) (Utils.listTraverse (\k -> Task.fmap (Tuple.pair k) (toValue k)) keys) + + + +-- ANY + + +any : (v -> Bool) -> Dict c k v -> Bool +any isGood dict = + Dict.foldl (\_ _ -> EQ) (\_ v acc -> isGood v || acc) False dict diff --git a/src/Compiler/Data/Name.elm b/src/Compiler/Data/Name.elm new file mode 100644 index 0000000000..a6297b81ff --- /dev/null +++ b/src/Compiler/Data/Name.elm @@ -0,0 +1,486 @@ +module Compiler.Data.Name exposing + ( Name + , array + , basics + , bitwise + , bool + , char + , cmd + , debug + , debugger + , dict + , dollar + , false + , float + , fromManyNames + , fromPtr + , fromTypeVariable + , fromTypeVariableScheme + , fromVarIndex + , fromWords + , getKernel + , hasDot + , identity_ + , int + , isAppendableType + , isCompappendType + , isComparableType + , isKernel + , isNumberType + , jsArray + , list + , mainModule + , main_ + , maybe + , negate + , node + , platform + , program + , replModule + , replValueToPrint + , result + , router + , sepBy + , shader + , splitDots + , string + , sub + , task + , toChars + , toElmString + , true + , tuple + , utils + , value + , virtualDom + ) + +import Utils.Crash exposing (crash) + + + +-- NAME + + +type alias Name = + String + + + +-- TO + + +toChars : Name -> List Char +toChars = + String.toList + + +toElmString : Name -> String +toElmString = + identity + + + +-- FROM + + +fromPtr : String -> Int -> Int -> Name +fromPtr src start end = + String.slice start end src + + + +-- HAS DOT + + +hasDot : Name -> Bool +hasDot = + String.contains "." + + +splitDots : Name -> List String +splitDots = + String.split "." + + + +-- GET KERNEL + + +getKernel : Name -> Name +getKernel name = + if isKernel name then + String.dropLeft (String.length prefixKernel) name + + else + crash "AssertionFailed" + + + +-- STARTS WITH + + +isKernel : Name -> Bool +isKernel = + String.startsWith prefixKernel + + +isNumberType : Name -> Bool +isNumberType = + String.startsWith prefixNumber + + +isComparableType : Name -> Bool +isComparableType = + String.startsWith prefixComparable + + +isAppendableType : Name -> Bool +isAppendableType = + String.startsWith prefixAppendable + + +isCompappendType : Name -> Bool +isCompappendType = + String.startsWith prefixCompappend + + +prefixKernel : Name +prefixKernel = + "Elm.Kernel." + + +prefixNumber : Name +prefixNumber = + "number" + + +prefixComparable : Name +prefixComparable = + "comparable" + + +prefixAppendable : Name +prefixAppendable = + "appendable" + + +prefixCompappend : Name +prefixCompappend = + "compappend" + + + +-- FROM VAR INDEX + + +fromVarIndex : Int -> Name +fromVarIndex n = + writeDigitsAtEnd "_v" n + + +writeDigitsAtEnd : String -> Int -> String +writeDigitsAtEnd prefix n = + prefix ++ String.fromInt n + + + +-- FROM TYPE VARIABLE + + +fromTypeVariable : Name -> Int -> Name +fromTypeVariable name index = + if index <= 0 then + name + + else + name + |> String.toList + |> List.reverse + |> List.head + |> Maybe.map + (\lastChar -> + if Char.isDigit lastChar then + writeDigitsAtEnd (name ++ "_") index + + else + writeDigitsAtEnd name index + ) + |> Maybe.withDefault name + + + +-- FROM TYPE VARIABLE SCHEME + + +fromTypeVariableScheme : Int -> Name +fromTypeVariableScheme scheme = + if scheme < 26 then + (0x61 + scheme) + |> Char.fromCode + |> String.fromChar + + else + -- do + -- let (extra, letter) = List.quotRem scheme 26 + -- let size = 1 + getIndexSize extra + -- mba <- newByteArray size + -- writeWord8 mba 0 (0x61 + Word.fromInt letter) + -- writeDigitsAtEnd mba size extra + -- freeze mba + let + letter : Int + letter = + remainderBy 26 scheme + + extra : Int + extra = + max 0 (scheme - letter) + in + writeDigitsAtEnd + ((0x61 + letter) + |> Char.fromCode + |> String.fromChar + ) + extra + + + +-- FROM MANY NAMES +-- +-- Creating a unique name by combining all the subnames can create names +-- longer than 256 bytes relatively easily. So instead, the first given name +-- (e.g. foo) is prefixed chars that are valid in JS but not Elm (e.g. _M$foo) +-- +-- This should be a unique name since 0.19 disallows shadowing. It would not +-- be possible for multiple top-level cycles to include values with the same +-- name, so the important thing is to make the cycle name distinct from the +-- normal name. Same logic for destructuring patterns like (x,y) + + +fromManyNames : List Name -> Name +fromManyNames names = + case names of + [] -> + blank + + -- NOTE: this case is needed for (let _ = Debug.log "x" x in ...) + -- but maybe unused patterns should be stripped out instead + firstName :: _ -> + blank ++ firstName + + +blank : Name +blank = + "_M$" + + + +-- FROM WORDS + + +fromWords : List Char -> Name +fromWords words = + String.fromList words + + + +-- writeWords : MBA s -> Int -> List Word.Word8 -> ST s () +-- writeWords !mba !i words = +-- case words of +-- [] -> +-- () +-- w :: ws -> +-- do +-- writeWord8 mba i w +-- writeWords mba (i + 1) ws +-- SEP BY + + +sepBy : Char -> Name -> Name -> Name +sepBy sep ba1 ba2 = + String.join (String.fromChar sep) [ ba1, ba2 ] + + + +-- COMMON NAMES + + +int : Name +int = + "Int" + + +float : Name +float = + "Float" + + +bool : Name +bool = + "Bool" + + +char : Name +char = + "Char" + + +string : Name +string = + "String" + + +maybe : Name +maybe = + "Maybe" + + +result : Name +result = + "Result" + + +list : Name +list = + "List" + + +array : Name +array = + "Array" + + +dict : Name +dict = + "Dict" + + +tuple : Name +tuple = + "Tuple" + + +jsArray : Name +jsArray = + "JsArray" + + +task : Name +task = + "Task" + + +router : Name +router = + "Router" + + +cmd : Name +cmd = + "Cmd" + + +sub : Name +sub = + "Sub" + + +platform : Name +platform = + "Platform" + + +virtualDom : Name +virtualDom = + "VirtualDom" + + +shader : Name +shader = + "Shader" + + +debug : Name +debug = + "Debug" + + +debugger : Name +debugger = + "Debugger" + + +bitwise : Name +bitwise = + "Bitwise" + + +basics : Name +basics = + "Basics" + + +utils : Name +utils = + "Utils" + + +negate : Name +negate = + "negate" + + +true : Name +true = + "True" + + +false : Name +false = + "False" + + +value : Name +value = + "Value" + + +node : Name +node = + "Node" + + +program : Name +program = + "Program" + + +main_ : Name +main_ = + "main" + + +mainModule : Name +mainModule = + "Main" + + +dollar : Name +dollar = + "$" + + +identity_ : Name +identity_ = + "identity" + + +replModule : Name +replModule = + "Elm_Repl" + + +replValueToPrint : Name +replValueToPrint = + "repl_input_value_" diff --git a/src/Compiler/Data/NonEmptyList.elm b/src/Compiler/Data/NonEmptyList.elm new file mode 100644 index 0000000000..3977d5f942 --- /dev/null +++ b/src/Compiler/Data/NonEmptyList.elm @@ -0,0 +1,71 @@ +module Compiler.Data.NonEmptyList exposing + ( Nonempty(..) + , cons + , foldr + , map + , singleton + , sortBy + , toList + ) + +-- LIST + + +type Nonempty a + = Nonempty a (List a) + + +singleton : a -> Nonempty a +singleton a = + Nonempty a [] + + +cons : a -> Nonempty a -> Nonempty a +cons a (Nonempty b bs) = + Nonempty b (bs ++ [ a ]) + + +toList : Nonempty a -> List a +toList (Nonempty x xs) = + x :: xs + + + +-- INSTANCES + + +map : (a -> b) -> Nonempty a -> Nonempty b +map func (Nonempty x xs) = + Nonempty (func x) (List.map func xs) + + +foldr : (a -> b -> b) -> b -> Nonempty a -> b +foldr step state (Nonempty x xs) = + List.foldr step state (x :: xs) + + + +-- SORT BY + + +sortBy : (a -> comparable) -> Nonempty a -> Nonempty a +sortBy toRank (Nonempty x xs) = + let + comparison : a -> a -> Order + comparison a b = + compare (toRank a) (toRank b) + in + case List.sortWith comparison xs of + [] -> + Nonempty x [] + + y :: ys -> + case comparison x y of + LT -> + Nonempty x (y :: ys) + + EQ -> + Nonempty x (y :: ys) + + GT -> + Nonempty y (List.sortWith comparison (x :: ys)) diff --git a/src/Compiler/Data/OneOrMore.elm b/src/Compiler/Data/OneOrMore.elm new file mode 100644 index 0000000000..2aa3e32545 --- /dev/null +++ b/src/Compiler/Data/OneOrMore.elm @@ -0,0 +1,92 @@ +module Compiler.Data.OneOrMore exposing + ( OneOrMore(..) + , destruct + , getFirstTwo + , map + , more + , one + ) + +-- ONE OR MORE + + +type OneOrMore a + = One a + | More (OneOrMore a) (OneOrMore a) + + +one : a -> OneOrMore a +one = + One + + +more : OneOrMore a -> OneOrMore a -> OneOrMore a +more = + More + + + +-- MAP + + +map : (a -> b) -> OneOrMore a -> OneOrMore b +map func oneOrMore = + case oneOrMore of + One value -> + One (func value) + + More left right -> + More (map func left) (map func right) + + + +-- DESTRUCT + + +destruct : (a -> List a -> b) -> OneOrMore a -> b +destruct func oneOrMore = + destructLeft func oneOrMore [] + + +destructLeft : (a -> List a -> b) -> OneOrMore a -> List a -> b +destructLeft func oneOrMore xs = + case oneOrMore of + One x -> + func x xs + + More a b -> + destructLeft func a (destructRight b xs) + + +destructRight : OneOrMore a -> List a -> List a +destructRight oneOrMore xs = + case oneOrMore of + One x -> + x :: xs + + More a b -> + destructRight a (destructRight b xs) + + + +-- GET FIRST TWO + + +getFirstTwo : OneOrMore a -> OneOrMore a -> ( a, a ) +getFirstTwo left right = + case left of + One x -> + ( x, getFirstOne right ) + + More lleft lright -> + getFirstTwo lleft lright + + +getFirstOne : OneOrMore a -> a +getFirstOne oneOrMore = + case oneOrMore of + One x -> + x + + More left _ -> + getFirstOne left diff --git a/src/Compiler/Elm/Compiler/Imports.elm b/src/Compiler/Elm/Compiler/Imports.elm new file mode 100644 index 0000000000..0571fe9784 --- /dev/null +++ b/src/Compiler/Elm/Compiler/Imports.elm @@ -0,0 +1,56 @@ +module Compiler.Elm.Compiler.Imports exposing (defaults) + +import Compiler.AST.Source as Src +import Compiler.Data.Name as Name exposing (Name) +import Compiler.Elm.ModuleName as ModuleName +import Compiler.Reporting.Annotation as A +import System.TypeCheck.IO as IO + + + +-- DEFAULTS + + +defaults : List (Src.C1 Src.Import) +defaults = + [ ( [], import_ ModuleName.basics Nothing (Src.Open [] []) ) + , ( [], import_ ModuleName.debug Nothing closed ) + , ( [], import_ ModuleName.list Nothing (operator "::") ) + , ( [], import_ ModuleName.maybe Nothing (typeOpen Name.maybe) ) + , ( [], import_ ModuleName.result Nothing (typeOpen Name.result) ) + , ( [], import_ ModuleName.string Nothing (typeClosed Name.string) ) + , ( [], import_ ModuleName.char Nothing (typeClosed Name.char) ) + , ( [], import_ ModuleName.tuple Nothing closed ) + , ( [], import_ ModuleName.platform Nothing (typeClosed Name.program) ) + , ( [], import_ ModuleName.cmd (Just Name.cmd) (typeClosed Name.cmd) ) + , ( [], import_ ModuleName.sub (Just Name.sub) (typeClosed Name.sub) ) + ] + + +import_ : IO.Canonical -> Maybe Name -> Src.Exposing -> Src.Import +import_ (IO.Canonical _ name) maybeAlias exposing_ = + Src.Import ( [], A.At A.zero name ) (Maybe.map (\alias_ -> ( ( [], [] ), alias_ )) maybeAlias) ( ( [], [] ), exposing_ ) + + + +-- EXPOSING + + +closed : Src.Exposing +closed = + Src.Explicit (A.At A.zero []) + + +typeOpen : Name -> Src.Exposing +typeOpen name = + Src.Explicit (A.At A.zero [ ( ( [], [] ), Src.Upper (A.At A.zero name) ( [], Src.Public A.zero ) ) ]) + + +typeClosed : Name -> Src.Exposing +typeClosed name = + Src.Explicit (A.At A.zero [ ( ( [], [] ), Src.Upper (A.At A.zero name) ( [], Src.Private ) ) ]) + + +operator : Name -> Src.Exposing +operator op = + Src.Explicit (A.At A.zero [ ( ( [], [] ), Src.Operator A.zero op ) ]) diff --git a/src/Compiler/Elm/Compiler/Type.elm b/src/Compiler/Elm/Compiler/Type.elm new file mode 100644 index 0000000000..d27f6025e6 --- /dev/null +++ b/src/Compiler/Elm/Compiler/Type.elm @@ -0,0 +1,376 @@ +module Compiler.Elm.Compiler.Type exposing + ( Alias(..) + , DebugMetadata(..) + , Type(..) + , Union(..) + , bytesDecoder + , bytesEncoder + , decoder + , encode + , encodeMetadata + , jsonDecoder + , jsonEncoder + , toDoc + ) + +import Compiler.AST.Source as Src +import Compiler.Data.Name as Name +import Compiler.Json.Decode as D exposing (Decoder) +import Compiler.Json.Encode as E exposing (Value) +import Compiler.Json.String as Json +import Compiler.Parse.Primitives as P +import Compiler.Parse.Type as Type +import Compiler.Reporting.Annotation as A +import Compiler.Reporting.Doc as D +import Compiler.Reporting.Render.Type as RT +import Compiler.Reporting.Render.Type.Localizer as L +import Json.Decode as Decode +import Json.Encode as Encode +import Utils.Bytes.Decode as BD +import Utils.Bytes.Encode as BE +import Utils.Crash exposing (crash) + + + +-- TYPES + + +type Type + = Lambda Type Type + | Var Name.Name + | Type Name.Name (List Type) + | Record (List ( Name.Name, Type )) (Maybe Name.Name) + | Unit + | Tuple Type Type (List Type) + + +type DebugMetadata + = DebugMetadata Type (List Alias) (List Union) + + +type Alias + = Alias Name.Name (List Name.Name) Type + + +type Union + = Union Name.Name (List Name.Name) (List ( Name.Name, List Type )) + + + +-- TO DOC + + +toDoc : L.Localizer -> RT.Context -> Type -> D.Doc +toDoc localizer context tipe = + case tipe of + Lambda _ _ -> + case List.map (toDoc localizer RT.Func) (collectLambdas tipe) of + a :: b :: cs -> + RT.lambda context a b cs + + _ -> + crash "toDoc Lambda" + + Var name -> + D.fromName name + + Unit -> + D.fromChars "()" + + Tuple a b cs -> + RT.tuple + (toDoc localizer RT.None a) + (toDoc localizer RT.None b) + (List.map (toDoc localizer RT.None) cs) + + Type name args -> + RT.apply + context + (D.fromName name) + (List.map (toDoc localizer RT.App) args) + + Record fields ext -> + RT.record + (List.map (entryToDoc localizer) fields) + (Maybe.map D.fromName ext) + + +entryToDoc : L.Localizer -> ( Name.Name, Type ) -> ( D.Doc, D.Doc ) +entryToDoc localizer ( field, fieldType ) = + ( D.fromName field, toDoc localizer RT.None fieldType ) + + +collectLambdas : Type -> List Type +collectLambdas tipe = + case tipe of + Lambda arg body -> + arg :: collectLambdas body + + _ -> + [ tipe ] + + + +-- JSON for TYPE + + +encode : Type -> Value +encode tipe = + E.string (D.toLine (toDoc L.empty RT.None tipe)) + + +decoder : Decoder () Type +decoder = + D.customString parser (\_ _ -> ()) + + +parser : P.Parser () Type +parser = + P.specialize (\_ _ _ -> ()) (P.fmap fromRawType (P.fmap (Tuple.first >> Tuple.second) (Type.expression []))) + + +fromRawType : Src.Type -> Type +fromRawType (A.At _ astType) = + case astType of + Src.TLambda ( _, t1 ) ( _, t2 ) -> + Lambda (fromRawType t1) (fromRawType t2) + + Src.TVar x -> + Var x + + Src.TUnit -> + Unit + + Src.TTuple ( _, a ) ( _, b ) cs -> + Tuple + (fromRawType a) + (fromRawType b) + (List.map (Src.c2EolValue >> fromRawType) cs) + + Src.TType _ name args -> + Type name (List.map fromRawType (List.map Tuple.second args)) + + Src.TTypeQual _ _ name args -> + Type name (List.map fromRawType (List.map Tuple.second args)) + + Src.TRecord fields maybeExt _ -> + let + fromField : Src.C2 ( Src.C1 (A.Located a), Src.C1 Src.Type ) -> ( a, Type ) + fromField ( _, ( ( _, A.At _ field ), ( _, tipe ) ) ) = + ( field, fromRawType tipe ) + in + Record + (List.map fromField fields) + (Maybe.map (\( _, A.At _ ext ) -> ext) maybeExt) + + Src.TParens ( _, astType_ ) -> + fromRawType astType_ + + + +-- JSON for PROGRAM + + +encodeMetadata : DebugMetadata -> Value +encodeMetadata (DebugMetadata msg aliases unions) = + E.object + [ ( "message", encode msg ) + , ( "aliases", E.object (List.map toTypeAliasField aliases) ) + , ( "unions", E.object (List.map toCustomTypeField unions) ) + ] + + +toTypeAliasField : Alias -> ( String, Value ) +toTypeAliasField (Alias name args tipe) = + ( Json.fromName name + , E.object + [ ( "args", E.list E.string args ) + , ( "type", encode tipe ) + ] + ) + + +toCustomTypeField : Union -> ( String, Value ) +toCustomTypeField (Union name args constructors) = + ( Json.fromName name + , E.object + [ ( "args", E.list E.string args ) + , ( "tags", E.object (List.map toVariantObject constructors) ) + ] + ) + + +toVariantObject : ( Name.Name, List Type ) -> ( String, Value ) +toVariantObject ( name, args ) = + ( Json.fromName name, E.list encode args ) + + + +-- JSON ENCODERS and DECODERS + + +jsonEncoder : Type -> Encode.Value +jsonEncoder type_ = + case type_ of + Lambda arg body -> + Encode.object + [ ( "type", Encode.string "Lambda" ) + , ( "arg", jsonEncoder arg ) + , ( "body", jsonEncoder body ) + ] + + Var name -> + Encode.object + [ ( "type", Encode.string "Var" ) + , ( "name", Encode.string name ) + ] + + Type name args -> + Encode.object + [ ( "type", Encode.string "Type" ) + , ( "name", Encode.string name ) + , ( "args", Encode.list jsonEncoder args ) + ] + + Record fields ext -> + Encode.object + [ ( "type", Encode.string "Record" ) + , ( "fields", Encode.list (E.jsonPair Encode.string jsonEncoder) fields ) + , ( "ext", E.maybe Encode.string ext ) + ] + + Unit -> + Encode.object + [ ( "type", Encode.string "Unit" ) + ] + + Tuple a b cs -> + Encode.object + [ ( "type", Encode.string "Tuple" ) + , ( "a", jsonEncoder a ) + , ( "b", jsonEncoder b ) + , ( "cs", Encode.list jsonEncoder cs ) + ] + + +jsonDecoder : Decode.Decoder Type +jsonDecoder = + Decode.field "type" Decode.string + |> Decode.andThen + (\type_ -> + case type_ of + "Lambda" -> + Decode.map2 Lambda + (Decode.field "arg" jsonDecoder) + (Decode.field "body" jsonDecoder) + + "Var" -> + Decode.map Var + (Decode.field "name" Decode.string) + + "Type" -> + Decode.map2 Type + (Decode.field "name" Decode.string) + (Decode.field "args" (Decode.list jsonDecoder)) + + "Record" -> + Decode.map2 Record + (Decode.field "fields" (Decode.list (D.jsonPair Decode.string jsonDecoder))) + (Decode.field "ext" (Decode.maybe Decode.string)) + + "Unit" -> + Decode.succeed Unit + + "Tuple" -> + Decode.map3 Tuple + (Decode.field "a" jsonDecoder) + (Decode.field "b" jsonDecoder) + (Decode.field "cs" (Decode.list jsonDecoder)) + + _ -> + Decode.fail ("Failed to decode Type's type: " ++ type_) + ) + + + +-- ENCODERS and DECODERS + + +bytesEncoder : Type -> BE.Encoder +bytesEncoder type_ = + case type_ of + Lambda arg body -> + BE.sequence + [ BE.unsignedInt8 0 + , bytesEncoder arg + , bytesEncoder body + ] + + Var name -> + BE.sequence + [ BE.unsignedInt8 1 + , BE.string name + ] + + Type name args -> + BE.sequence + [ BE.unsignedInt8 2 + , BE.string name + , BE.list bytesEncoder args + ] + + Record fields ext -> + BE.sequence + [ BE.unsignedInt8 3 + , BE.list (BE.jsonPair BE.string bytesEncoder) fields + , BE.maybe BE.string ext + ] + + Unit -> + BE.unsignedInt8 4 + + Tuple a b cs -> + BE.sequence + [ BE.unsignedInt8 5 + , bytesEncoder a + , bytesEncoder b + , BE.list bytesEncoder cs + ] + + +bytesDecoder : BD.Decoder Type +bytesDecoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.map2 Lambda + bytesDecoder + bytesDecoder + + 1 -> + BD.map Var BD.string + + 2 -> + BD.map2 Type + BD.string + (BD.list bytesDecoder) + + 3 -> + BD.map2 Record + (BD.list (BD.jsonPair BD.string bytesDecoder)) + (BD.maybe BD.string) + + 4 -> + BD.succeed Unit + + 5 -> + BD.map3 Tuple + bytesDecoder + bytesDecoder + (BD.list bytesDecoder) + + _ -> + BD.fail + ) diff --git a/src/Compiler/Elm/Compiler/Type/Extract.elm b/src/Compiler/Elm/Compiler/Type/Extract.elm new file mode 100644 index 0000000000..d2eedc3efa --- /dev/null +++ b/src/Compiler/Elm/Compiler/Type/Extract.elm @@ -0,0 +1,337 @@ +module Compiler.Elm.Compiler.Type.Extract exposing + ( Types(..) + , Types_ + , fromDependencyInterface + , fromInterface + , fromMsg + , fromType + , merge + , mergeMany + , typesDecoder + , typesEncoder + ) + +import Compiler.AST.Canonical as Can +import Compiler.AST.Optimized as Opt +import Compiler.AST.Utils.Type as Type +import Compiler.Data.Name as Name +import Compiler.Elm.Compiler.Type as T +import Compiler.Elm.Interface as I +import Compiler.Elm.ModuleName as ModuleName +import Data.Map as Dict exposing (Dict) +import Data.Set as EverySet exposing (EverySet) +import System.TypeCheck.IO as IO +import Utils.Bytes.Decode as BD +import Utils.Bytes.Encode as BE +import Utils.Main as Utils + + + +-- EXTRACTION + + +fromType : Can.Type -> T.Type +fromType astType = + Tuple.second (run (extract astType)) + + +extract : Can.Type -> Extractor T.Type +extract astType = + case astType of + Can.TLambda arg result -> + pure T.Lambda + |> apply (extract arg) + |> apply (extract result) + + Can.TVar x -> + pure (T.Var x) + + Can.TType home name args -> + addUnion (Opt.Global home name) (T.Type (toPublicName home name)) + |> apply (traverse extract args) + + Can.TRecord fields ext -> + traverse (tupleTraverse extract) (Can.fieldsToList fields) + |> fmap (\efields -> T.Record efields ext) + + Can.TUnit -> + pure T.Unit + + Can.TTuple a b cs -> + pure T.Tuple + |> apply (extract a) + |> apply (extract b) + |> apply (traverse extract cs) + + Can.TAlias home name args aliasType -> + addAlias (Opt.Global home name) () + |> bind + (\_ -> + extract (Type.dealias args aliasType) + |> bind + (\_ -> + fmap (T.Type (toPublicName home name)) + (traverse (extract << Tuple.second) args) + ) + ) + + +toPublicName : IO.Canonical -> Name.Name -> Name.Name +toPublicName (IO.Canonical _ home) name = + Name.sepBy '.' home name + + + +-- TRANSITIVELY AVAILABLE TYPES + + +type Types + = -- PERF profile Opt.Global representation + -- current representation needs less allocation + -- but maybe the lookup is much worse + Types (Dict (List String) IO.Canonical Types_) + + +type Types_ + = Types_ (Dict String Name.Name Can.Union) (Dict String Name.Name Can.Alias) + + +mergeMany : List Types -> Types +mergeMany listOfTypes = + case listOfTypes of + [] -> + Types Dict.empty + + t :: ts -> + List.foldr merge t ts + + +merge : Types -> Types -> Types +merge (Types types1) (Types types2) = + Types (Dict.union types1 types2) + + +fromInterface : ModuleName.Raw -> I.Interface -> Types +fromInterface name (I.Interface pkg _ unions aliases _) = + Types <| + Dict.singleton ModuleName.toComparableCanonical (IO.Canonical pkg name) <| + Types_ (Dict.map (\_ -> I.extractUnion) unions) (Dict.map (\_ -> I.extractAlias) aliases) + + +fromDependencyInterface : IO.Canonical -> I.DependencyInterface -> Types +fromDependencyInterface home di = + Types + (Dict.singleton ModuleName.toComparableCanonical home <| + case di of + I.Public (I.Interface _ _ unions aliases _) -> + Types_ (Dict.map (\_ -> I.extractUnion) unions) (Dict.map (\_ -> I.extractAlias) aliases) + + I.Private _ unions aliases -> + Types_ unions aliases + ) + + + +-- EXTRACT MODEL, MSG, AND ANY TRANSITIVE DEPENDENCIES + + +fromMsg : Types -> Can.Type -> T.DebugMetadata +fromMsg types message = + let + ( msgDeps, msgType ) = + run (extract message) + + ( aliases, unions ) = + extractTransitive types noDeps msgDeps + in + T.DebugMetadata msgType aliases unions + + +extractTransitive : Types -> Deps -> Deps -> ( List T.Alias, List T.Union ) +extractTransitive types (Deps seenAliases seenUnions) (Deps nextAliases nextUnions) = + let + aliases : EverySet (List String) Opt.Global + aliases = + EverySet.diff nextAliases seenAliases + + unions : EverySet (List String) Opt.Global + unions = + EverySet.diff nextUnions seenUnions + in + if EverySet.isEmpty aliases && EverySet.isEmpty unions then + ( [], [] ) + + else + let + ( newDeps, ( resultAlias, resultUnion ) ) = + run + (pure Tuple.pair + |> apply (traverse (extractAlias types) (EverySet.toList Opt.compareGlobal aliases)) + |> apply (traverse (extractUnion types) (EverySet.toList Opt.compareGlobal unions)) + ) + + oldDeps : Deps + oldDeps = + Deps (EverySet.union seenAliases nextAliases) (EverySet.union seenUnions nextUnions) + + ( remainingResultAlias, remainingResultUnion ) = + extractTransitive types oldDeps newDeps + in + ( resultAlias ++ remainingResultAlias, resultUnion ++ remainingResultUnion ) + + +extractAlias : Types -> Opt.Global -> Extractor T.Alias +extractAlias (Types dict) (Opt.Global home name) = + let + (Can.Alias args aliasType) = + Utils.find ModuleName.toComparableCanonical home dict + |> (\(Types_ _ aliasInfo) -> aliasInfo) + |> Utils.find identity name + in + fmap (T.Alias (toPublicName home name) args) (extract aliasType) + + +extractUnion : Types -> Opt.Global -> Extractor T.Union +extractUnion (Types dict) (Opt.Global home name) = + if name == Name.list && home == ModuleName.list then + pure <| T.Union (toPublicName home name) [ "a" ] [] + + else + let + pname : Name.Name + pname = + toPublicName home name + + (Can.Union vars ctors _ _) = + Utils.find ModuleName.toComparableCanonical home dict + |> (\(Types_ unionInfo _) -> unionInfo) + |> Utils.find identity name + in + fmap (T.Union pname vars) (traverse extractCtor ctors) + + +extractCtor : Can.Ctor -> Extractor ( Name.Name, List T.Type ) +extractCtor (Can.Ctor ctor _ _ args) = + fmap (Tuple.pair ctor) (traverse extract args) + + + +-- DEPS + + +type Deps + = Deps (EverySet (List String) Opt.Global) (EverySet (List String) Opt.Global) + + +noDeps : Deps +noDeps = + Deps EverySet.empty EverySet.empty + + + +-- EXTRACTOR + + +type Extractor a + = Extractor (EverySet (List String) Opt.Global -> EverySet (List String) Opt.Global -> EResult a) + + +type EResult a + = EResult (EverySet (List String) Opt.Global) (EverySet (List String) Opt.Global) a + + +run : Extractor a -> ( Deps, a ) +run (Extractor k) = + case k EverySet.empty EverySet.empty of + EResult aliases unions value -> + ( Deps aliases unions, value ) + + +addAlias : Opt.Global -> a -> Extractor a +addAlias alias value = + Extractor <| + \aliases unions -> + EResult (EverySet.insert Opt.toComparableGlobal alias aliases) unions value + + +addUnion : Opt.Global -> a -> Extractor a +addUnion union value = + Extractor <| + \aliases unions -> + EResult aliases (EverySet.insert Opt.toComparableGlobal union unions) value + + +fmap : (a -> b) -> Extractor a -> Extractor b +fmap func (Extractor k) = + Extractor <| + \aliases unions -> + case k aliases unions of + EResult a1 u1 value -> + EResult a1 u1 (func value) + + +pure : a -> Extractor a +pure value = + Extractor (\aliases unions -> EResult aliases unions value) + + +apply : Extractor a -> Extractor (a -> b) -> Extractor b +apply (Extractor kv) (Extractor kf) = + Extractor <| + \aliases unions -> + case kf aliases unions of + EResult a1 u1 func -> + case kv a1 u1 of + EResult a2 u2 value -> + EResult a2 u2 (func value) + + +bind : (a -> Extractor b) -> Extractor a -> Extractor b +bind callback (Extractor ka) = + Extractor <| + \aliases unions -> + case ka aliases unions of + EResult a1 u1 value -> + case callback value of + Extractor kb -> + kb a1 u1 + + +traverse : (a -> Extractor b) -> List a -> Extractor (List b) +traverse f = + List.foldr (\a -> bind (\c -> fmap (\va -> va :: c) (f a))) + (pure []) + + +tupleTraverse : (b -> Extractor c) -> ( a, b ) -> Extractor ( a, c ) +tupleTraverse f ( a, b ) = + fmap (Tuple.pair a) (f b) + + + +-- ENCODERS and DECODERS + + +typesEncoder : Types -> BE.Encoder +typesEncoder (Types types) = + BE.assocListDict ModuleName.compareCanonical ModuleName.canonicalEncoder types_Encoder types + + +typesDecoder : BD.Decoder Types +typesDecoder = + BD.map Types (BD.assocListDict ModuleName.toComparableCanonical ModuleName.canonicalDecoder types_Decoder) + + +types_Encoder : Types_ -> BE.Encoder +types_Encoder (Types_ unionInfo aliasInfo) = + BE.sequence + [ BE.assocListDict compare BE.string Can.unionEncoder unionInfo + , BE.assocListDict compare BE.string Can.aliasEncoder aliasInfo + ] + + +types_Decoder : BD.Decoder Types_ +types_Decoder = + BD.map2 Types_ + (BD.assocListDict identity BD.string Can.unionDecoder) + (BD.assocListDict identity BD.string Can.aliasDecoder) diff --git a/src/Compiler/Elm/Constraint.elm b/src/Compiler/Elm/Constraint.elm new file mode 100644 index 0000000000..4fffd5cc04 --- /dev/null +++ b/src/Compiler/Elm/Constraint.elm @@ -0,0 +1,274 @@ +module Compiler.Elm.Constraint exposing + ( Constraint + , Error(..) + , anything + , decoder + , defaultElm + , encode + , exactly + , goodElm + , intersect + , lowerBound + , satisfies + , toChars + , untilNextMajor + , untilNextMinor + ) + +import Compiler.Elm.Version as V +import Compiler.Json.Decode as D exposing (Decoder) +import Compiler.Json.Encode as E exposing (Value) +import Compiler.Parse.Primitives as P exposing (Col, Row) + + + +-- CONSTRAINTS + + +type Constraint + = Range V.Version Op Op V.Version + + +type Op + = Less + | LessOrEqual + + + +-- COMMON CONSTRAINTS + + +exactly : V.Version -> Constraint +exactly version = + Range version LessOrEqual LessOrEqual version + + +anything : Constraint +anything = + Range V.one LessOrEqual LessOrEqual V.maxVersion + + + +-- EXTRACT VERSION + + +lowerBound : Constraint -> V.Version +lowerBound (Range lower _ _ _) = + lower + + + +-- TO CHARS + + +toChars : Constraint -> String +toChars constraint = + case constraint of + Range lower lowerOp upperOp upper -> + V.toChars lower ++ opToChars lowerOp ++ "v" ++ opToChars upperOp ++ V.toChars upper + + +opToChars : Op -> String +opToChars op = + case op of + Less -> + " < " + + LessOrEqual -> + " <= " + + + +-- IS SATISFIED + + +satisfies : Constraint -> V.Version -> Bool +satisfies constraint version = + case constraint of + Range lower lowerOp upperOp upper -> + isLess lowerOp lower version + && isLess upperOp version upper + + +isLess : Op -> (V.Version -> V.Version -> Bool) +isLess op = + case op of + Less -> + \lower upper -> + V.compare lower upper == LT + + LessOrEqual -> + \lower upper -> + V.compare lower upper /= GT + + + +-- INTERSECT + + +intersect : Constraint -> Constraint -> Maybe Constraint +intersect (Range lo lop hop hi) (Range lo_ lop_ hop_ hi_) = + let + ( newLo, newLop ) = + case V.compare lo lo_ of + LT -> + ( lo_, lop_ ) + + EQ -> + ( lo + , if List.member Less [ lop, lop_ ] then + Less + + else + LessOrEqual + ) + + GT -> + ( lo, lop ) + + ( newHi, newHop ) = + case V.compare hi hi_ of + LT -> + ( hi, hop ) + + EQ -> + ( hi + , if List.member Less [ hop, hop_ ] then + Less + + else + LessOrEqual + ) + + GT -> + ( hi_, hop_ ) + in + if V.compare newLo newHi /= GT then + Just (Range newLo newLop newHop newHi) + + else + Nothing + + + +-- ELM CONSTRAINT + + +goodElm : Constraint -> Bool +goodElm constraint = + satisfies constraint V.elmCompiler + + +defaultElm : Constraint +defaultElm = + let + (V.Version major _ _) = + V.elmCompiler + in + if major > 0 then + untilNextMajor V.elmCompiler + + else + untilNextMinor V.elmCompiler + + + +-- CREATE CONSTRAINTS + + +untilNextMajor : V.Version -> Constraint +untilNextMajor version = + Range version LessOrEqual Less (V.bumpMajor version) + + +untilNextMinor : V.Version -> Constraint +untilNextMinor version = + Range version LessOrEqual Less (V.bumpMinor version) + + + +-- JSON + + +encode : Constraint -> Value +encode constraint = + E.string (toChars constraint) + + +decoder : Decoder Error Constraint +decoder = + D.customString parser BadFormat + + + +-- PARSER + + +type Error + = BadFormat Row Col + | InvalidRange V.Version V.Version + + +parser : P.Parser Error Constraint +parser = + parseVersion + |> P.bind + (\lower -> + P.word1 ' ' BadFormat + |> P.bind + (\_ -> + parseOp + |> P.bind + (\loOp -> + P.word1 ' ' BadFormat + |> P.bind + (\_ -> + P.word1 'v' BadFormat + |> P.bind + (\_ -> + P.word1 ' ' BadFormat + |> P.bind + (\_ -> + parseOp + |> P.bind + (\hiOp -> + P.word1 ' ' BadFormat + |> P.bind + (\_ -> + parseVersion + |> P.bind + (\higher -> + P.Parser <| + \((P.State _ _ _ _ row col) as state) -> + if V.compare lower higher == LT then + P.Eok (Range lower loOp hiOp higher) state + + else + P.Eerr row col (\_ _ -> InvalidRange lower higher) + ) + ) + ) + ) + ) + ) + ) + ) + ) + + +parseVersion : P.Parser Error V.Version +parseVersion = + P.specialize (\( r, c ) _ _ -> BadFormat r c) V.parser + + +parseOp : P.Parser Error Op +parseOp = + P.word1 '<' BadFormat + |> P.bind + (\_ -> + P.oneOfWithFallback + [ P.word1 '=' BadFormat + |> P.fmap (\_ -> LessOrEqual) + ] + Less + ) diff --git a/src/Compiler/Elm/Docs.elm b/src/Compiler/Elm/Docs.elm new file mode 100644 index 0000000000..5c685d6429 --- /dev/null +++ b/src/Compiler/Elm/Docs.elm @@ -0,0 +1,986 @@ +module Compiler.Elm.Docs exposing + ( Alias(..) + , Binop(..) + , Comment + , Documentation + , Error(..) + , Module(..) + , Union(..) + , Value(..) + , bytesDecoder + , bytesEncoder + , bytesModuleDecoder + , bytesModuleEncoder + , decoder + , encode + , fromModule + , jsonDecoder + , jsonEncoder + , jsonModuleDecoder + , jsonModuleEncoder + , parseOverview + ) + +import Basics.Extra exposing (flip) +import Compiler.AST.Canonical as Can +import Compiler.AST.Source as Src +import Compiler.AST.Utils.Binop as Binop +import Compiler.Data.Name as Name exposing (Name) +import Compiler.Data.NonEmptyList as NE +import Compiler.Data.OneOrMore as OneOrMore +import Compiler.Elm.Compiler.Type as Type +import Compiler.Elm.Compiler.Type.Extract as Extract +import Compiler.Elm.ModuleName as ModuleName +import Compiler.Json.Decode as D +import Compiler.Json.Encode as E +import Compiler.Json.String as Json +import Compiler.Parse.Primitives as P exposing (Col, Row, word1) +import Compiler.Parse.Space as Space +import Compiler.Parse.Symbol as Symbol +import Compiler.Parse.Variable as Var +import Compiler.Reporting.Annotation as A +import Compiler.Reporting.Error.Docs as E +import Compiler.Reporting.Result as Result +import Data.Map as Dict exposing (Dict) +import Json.Decode as Decode +import Json.Encode as Encode +import System.TypeCheck.IO as IO +import Utils.Bytes.Decode as BD +import Utils.Bytes.Encode as BE +import Utils.Main as Utils + + + +-- DOCUMENTATION + + +type alias Documentation = + Dict String Name Module + + +type Module + = Module Name Comment (Dict String Name Union) (Dict String Name Alias) (Dict String Name Value) (Dict String Name Binop) + + +type alias Comment = + String + + +type Alias + = Alias Comment (List Name) Type.Type + + +type Union + = Union Comment (List Name) (List ( Name, List Type.Type )) + + +type Value + = Value Comment Type.Type + + +type Binop + = Binop Comment Type.Type Binop.Associativity Binop.Precedence + + + +-- JSON + + +encode : Documentation -> E.Value +encode docs = + E.list encodeModule (Dict.values compare docs) + + +encodeModule : Module -> E.Value +encodeModule (Module name comment unions aliases values binops) = + E.object + [ ( "name", ModuleName.encode name ) + , ( "comment", E.string comment ) + , ( "unions", E.list encodeUnion (Dict.toList compare unions) ) + , ( "aliases", E.list encodeAlias (Dict.toList compare aliases) ) + , ( "values", E.list encodeValue (Dict.toList compare values) ) + , ( "binops", E.list encodeBinop (Dict.toList compare binops) ) + ] + + +type Error + = BadAssociativity + | BadModuleName + | BadType + + +decoder : D.Decoder Error Documentation +decoder = + D.fmap toDict (D.list moduleDecoder) + + +toDict : List Module -> Documentation +toDict modules = + Dict.fromList identity (List.map toDictHelp modules) + + +toDictHelp : Module -> ( Name.Name, Module ) +toDictHelp ((Module name _ _ _ _ _) as modul) = + ( name, modul ) + + +moduleDecoder : D.Decoder Error Module +moduleDecoder = + D.fmap Module (D.field "name" moduleNameDecoder) + |> D.apply (D.field "comment" D.string) + |> D.apply (D.field "unions" (dictDecoder union)) + |> D.apply (D.field "aliases" (dictDecoder alias_)) + |> D.apply (D.field "values" (dictDecoder value)) + |> D.apply (D.field "binops" (dictDecoder binop)) + + +dictDecoder : D.Decoder Error a -> D.Decoder Error (Dict String Name a) +dictDecoder entryDecoder = + D.fmap (Dict.fromList identity) (D.list (named entryDecoder)) + + +named : D.Decoder Error a -> D.Decoder Error ( Name.Name, a ) +named entryDecoder = + D.fmap Tuple.pair (D.field "name" nameDecoder) + |> D.apply entryDecoder + + +nameDecoder : D.Decoder e Name +nameDecoder = + D.string + + +moduleNameDecoder : D.Decoder Error ModuleName.Raw +moduleNameDecoder = + D.mapError (always BadModuleName) ModuleName.decoder + + +typeDecoder : D.Decoder Error Type.Type +typeDecoder = + D.mapError (always BadType) Type.decoder + + + +-- UNION JSON + + +encodeUnion : ( Name, Union ) -> E.Value +encodeUnion ( name, Union comment args cases ) = + E.object + [ ( "name", E.name name ) + , ( "comment", E.string comment ) + , ( "args", E.list E.name args ) + , ( "cases", E.list encodeCase cases ) + ] + + +union : D.Decoder Error Union +union = + D.fmap Union (D.field "comment" D.string) + |> D.apply (D.field "args" (D.list nameDecoder)) + |> D.apply (D.field "cases" (D.list caseDecoder)) + + +encodeCase : ( Name, List Type.Type ) -> E.Value +encodeCase ( tag, args ) = + E.list identity [ E.name tag, E.list Type.encode args ] + + +caseDecoder : D.Decoder Error ( Name.Name, List Type.Type ) +caseDecoder = + D.pair nameDecoder (D.list typeDecoder) + + + +-- ALIAS JSON + + +encodeAlias : ( Name, Alias ) -> E.Value +encodeAlias ( name, Alias comment args tipe ) = + E.object + [ ( "name", E.name name ) + , ( "comment", E.string comment ) + , ( "args", E.list E.name args ) + , ( "type", Type.encode tipe ) + ] + + +alias_ : D.Decoder Error Alias +alias_ = + D.fmap Alias (D.field "comment" D.string) + |> D.apply (D.field "args" (D.list nameDecoder)) + |> D.apply (D.field "type" typeDecoder) + + + +-- VALUE JSON + + +encodeValue : ( Name.Name, Value ) -> E.Value +encodeValue ( name, Value comment tipe ) = + E.object + [ ( "name", E.name name ) + , ( "comment", E.string comment ) + , ( "type", Type.encode tipe ) + ] + + +value : D.Decoder Error Value +value = + D.fmap Value (D.field "comment" D.string) + |> D.apply (D.field "type" typeDecoder) + + + +-- BINOP JSON + + +encodeBinop : ( Name, Binop ) -> E.Value +encodeBinop ( name, Binop comment tipe assoc prec ) = + E.object + [ ( "name", E.name name ) + , ( "comment", E.string comment ) + , ( "type", Type.encode tipe ) + , ( "associativity", encodeAssoc assoc ) + , ( "precedence", encodePrec prec ) + ] + + +binop : D.Decoder Error Binop +binop = + D.fmap Binop (D.field "comment" D.string) + |> D.apply (D.field "type" typeDecoder) + |> D.apply (D.field "associativity" assocDecoder) + |> D.apply (D.field "precedence" precDecoder) + + + +-- ASSOCIATIVITY JSON + + +encodeAssoc : Binop.Associativity -> E.Value +encodeAssoc assoc = + case assoc of + Binop.Left -> + E.string "left" + + Binop.Non -> + E.string "non" + + Binop.Right -> + E.string "right" + + +assocDecoder : D.Decoder Error Binop.Associativity +assocDecoder = + let + left : String + left = + "left" + + non : String + non = + "non" + + right : String + right = + "right" + in + D.string + |> D.bind + (\str -> + if str == left then + D.pure Binop.Left + + else if str == non then + D.pure Binop.Non + + else if str == right then + D.pure Binop.Right + + else + D.failure BadAssociativity + ) + + + +-- PRECEDENCE JSON + + +encodePrec : Binop.Precedence -> E.Value +encodePrec n = + E.int n + + +precDecoder : D.Decoder Error Binop.Precedence +precDecoder = + D.int + + + +-- FROM MODULE + + +fromModule : Can.Module -> Result E.Error Module +fromModule ((Can.Module _ exports docs _ _ _ _ _) as modul) = + case exports of + Can.ExportEverything region -> + Err (E.ImplicitExposing region) + + Can.Export exportDict -> + case docs of + Src.NoDocs region _ -> + Err (E.NoDocs region) + + Src.YesDocs overview comments -> + parseOverview overview + |> Result.andThen (checkNames exportDict) + |> Result.andThen (\_ -> checkDefs exportDict overview (Dict.fromList identity comments) modul) + + + +-- PARSE OVERVIEW + + +parseOverview : Src.Comment -> Result E.Error (List (A.Located Name.Name)) +parseOverview (Src.Comment snippet) = + case P.fromSnippet (chompOverview []) E.BadEnd snippet of + Err err -> + Err (E.SyntaxProblem err) + + Ok names -> + Ok names + + +type alias Parser a = + P.Parser E.SyntaxProblem a + + +chompOverview : List (A.Located Name.Name) -> Parser (List (A.Located Name.Name)) +chompOverview = + P.loop chompOverviewHelp + + +chompOverviewHelp : List (A.Located Name.Name) -> Parser (P.Step (List (A.Located Name.Name)) (List (A.Located Name.Name))) +chompOverviewHelp names = + chompUntilDocs + |> P.bind + (\isDocs -> + if isDocs then + Space.chomp E.Space + |> P.bind (\_ -> chompDocs names) + |> P.fmap P.Loop + + else + P.pure (P.Done names) + ) + + +chompDocs : List (A.Located Name.Name) -> Parser (List (A.Located Name.Name)) +chompDocs = + P.loop chompDocsHelp + + +chompDocsHelp : List (A.Located Name.Name) -> Parser (P.Step (List (A.Located Name.Name)) (List (A.Located Name.Name))) +chompDocsHelp names = + P.addLocation + (P.oneOf E.Name + [ Var.lower E.Name + , Var.upper E.Name + , chompOperator + ] + ) + |> P.bind + (\name -> + Space.chomp E.Space + |> P.bind + (\_ -> + P.oneOfWithFallback + [ P.getPosition + |> P.bind + (\pos -> + Space.checkIndent pos E.Comma + |> P.bind + (\_ -> + word1 ',' E.Comma + |> P.bind + (\_ -> + Space.chomp E.Space + |> P.fmap (\_ -> P.Loop (name :: names)) + ) + ) + ) + ] + (P.Done (name :: names)) + ) + ) + + +chompOperator : Parser Name +chompOperator = + word1 '(' E.Op + |> P.bind + (\_ -> + Symbol.operator E.Op E.OpBad + |> P.bind + (\op -> + word1 ')' E.Op + |> P.fmap (\_ -> op) + ) + ) + + + +-- TODO add rule that @docs must be after newline in 0.20 +-- + + +chompUntilDocs : Parser Bool +chompUntilDocs = + P.Parser + (\(P.State src pos end indent row col) -> + let + ( ( isDocs, newPos ), ( newRow, newCol ) ) = + untilDocs src pos end row col + + newState : P.State + newState = + P.State src newPos end indent newRow newCol + in + P.Cok isDocs newState + ) + + +untilDocs : String -> Int -> Int -> Row -> Col -> ( ( Bool, Int ), ( Row, Col ) ) +untilDocs src pos end row col = + if pos >= end then + ( ( False, pos ), ( row, col ) ) + + else + let + word : Char + word = + P.unsafeIndex src pos + in + if word == '\n' then + untilDocs src (pos + 1) end (row + 1) 1 + + else + let + pos5 : Int + pos5 = + pos + 5 + in + if + (pos5 <= end) + && (P.unsafeIndex src pos == '@') + && (P.unsafeIndex src (pos + 1) == 'd') + && (P.unsafeIndex src (pos + 2) == 'o') + && (P.unsafeIndex src (pos + 3) == 'c') + && (P.unsafeIndex src (pos + 4) == 's') + && (Var.getInnerWidth src pos5 end == 0) + then + ( ( True, pos5 ), ( row, col + 5 ) ) + + else + let + newPos : Int + newPos = + pos + P.getCharWidth word + in + untilDocs src newPos end row (col + 1) + + + +-- CHECK NAMES + + +checkNames : Dict String Name (A.Located Can.Export) -> List (A.Located Name) -> Result E.Error () +checkNames exports names = + let + docs : DocNameRegions + docs = + List.foldl addName Dict.empty names + + loneExport : Name -> A.Located Can.Export -> Result.RResult i w E.NameProblem A.Region -> Result.RResult i w E.NameProblem A.Region + loneExport name export_ _ = + onlyInExports name export_ + + checkBoth : Name -> A.Located Can.Export -> OneOrMore.OneOrMore A.Region -> Result.RResult i w E.NameProblem A.Region -> Result.RResult i w E.NameProblem A.Region + checkBoth n _ r _ = + isUnique n r + + loneDoc : Name -> OneOrMore.OneOrMore A.Region -> Result.RResult i w E.NameProblem A.Region -> Result.RResult i w E.NameProblem A.Region + loneDoc name regions _ = + onlyInDocs name regions + in + case Result.run (Dict.merge compare loneExport checkBoth loneDoc exports docs (Result.ok A.zero)) of + ( _, Ok _ ) -> + Ok () + + ( _, Err es ) -> + Err (E.NameProblems (OneOrMore.destruct NE.Nonempty es)) + + +type alias DocNameRegions = + Dict String Name (OneOrMore.OneOrMore A.Region) + + +addName : A.Located Name -> DocNameRegions -> DocNameRegions +addName (A.At region name) dict = + Utils.mapInsertWith identity OneOrMore.more name (OneOrMore.one region) dict + + +isUnique : Name -> OneOrMore.OneOrMore A.Region -> Result.RResult i w E.NameProblem A.Region +isUnique name regions = + case regions of + OneOrMore.One region -> + Result.ok region + + OneOrMore.More left right -> + let + ( r1, r2 ) = + OneOrMore.getFirstTwo left right + in + Result.throw (E.NameDuplicate name r1 r2) + + +onlyInDocs : Name -> OneOrMore.OneOrMore A.Region -> Result.RResult i w E.NameProblem a +onlyInDocs name regions = + isUnique name regions + |> Result.bind + (\region -> + Result.throw (E.NameOnlyInDocs name region) + ) + + +onlyInExports : Name -> A.Located Can.Export -> Result.RResult i w E.NameProblem a +onlyInExports name (A.At region _) = + Result.throw (E.NameOnlyInExports name region) + + + +-- CHECK DEFS + + +checkDefs : Dict String Name (A.Located Can.Export) -> Src.Comment -> Dict String Name Src.Comment -> Can.Module -> Result E.Error Module +checkDefs exportDict overview comments (Can.Module name _ _ decls unions aliases infixes effects) = + let + types : Types + types = + gatherTypes decls Dict.empty + + info : Info + info = + Info comments types unions aliases infixes effects + in + case Result.run (Result.mapTraverseWithKey identity compare (checkExport info) exportDict) of + ( _, Err problems ) -> + Err (E.DefProblems (OneOrMore.destruct NE.Nonempty problems)) + + ( _, Ok inserters ) -> + Ok (Dict.foldr compare (\_ -> (<|)) (emptyModule name overview) inserters) + + +emptyModule : IO.Canonical -> Src.Comment -> Module +emptyModule (IO.Canonical _ name) (Src.Comment overview) = + Module name (Json.fromComment overview) Dict.empty Dict.empty Dict.empty Dict.empty + + +type Info + = Info (Dict String Name.Name Src.Comment) (Dict String Name.Name (Result A.Region Can.Type)) (Dict String Name.Name Can.Union) (Dict String Name.Name Can.Alias) (Dict String Name.Name Can.Binop) Can.Effects + + +checkExport : Info -> Name -> A.Located Can.Export -> Result.RResult i w E.DefProblem (Module -> Module) +checkExport ((Info _ _ iUnions iAliases iBinops _) as info) name (A.At region export) = + case export of + Can.ExportValue -> + getType name info + |> Result.bind + (\tipe -> + getComment region name info + |> Result.bind + (\comment -> + Result.ok + (\(Module mName mComment mUnions mAliases mValues mBinops) -> + Module + mName + mComment + mUnions + mAliases + (Dict.insert identity name (Value comment tipe) mValues) + mBinops + ) + ) + ) + + Can.ExportBinop -> + let + (Can.Binop_ assoc prec realName) = + Utils.find identity name iBinops + in + getType realName info + |> Result.bind + (\tipe -> + getComment region realName info + |> Result.bind + (\comment -> + Result.ok + (\(Module mName mComment mUnions mAliases mValues mBinops) -> + Module + mName + mComment + mUnions + mAliases + mValues + (Dict.insert identity name (Binop comment tipe assoc prec) mBinops) + ) + ) + ) + + Can.ExportAlias -> + let + (Can.Alias tvars tipe) = + Utils.find identity name iAliases + in + getComment region name info + |> Result.bind + (\comment -> + Result.ok + (\(Module mName mComment mUnions mAliases mValues mBinops) -> + Module mName + mComment + mUnions + (Dict.insert identity name (Alias comment tvars (Extract.fromType tipe)) mAliases) + mValues + mBinops + ) + ) + + Can.ExportUnionOpen -> + let + (Can.Union tvars ctors _ _) = + Utils.find identity name iUnions + in + getComment region name info + |> Result.bind + (\comment -> + Result.ok + (\(Module mName mComment mUnions mAliases mValues mBinops) -> + Module mName + mComment + (Dict.insert identity name (Union comment tvars (List.map dector ctors)) mUnions) + mAliases + mValues + mBinops + ) + ) + + Can.ExportUnionClosed -> + let + (Can.Union tvars _ _ _) = + Utils.find identity name iUnions + in + getComment region name info + |> Result.bind + (\comment -> + Result.ok + (\(Module mName mComment mUnions mAliases mValues mBinops) -> + Module mName + mComment + (Dict.insert identity name (Union comment tvars []) mUnions) + mAliases + mValues + mBinops + ) + ) + + Can.ExportPort -> + getType name info + |> Result.bind + (\tipe -> + getComment region name info + |> Result.bind + (\comment -> + Result.ok + (\(Module mName mComment mUnions mAliases mValues mBinops) -> + Module mName + mComment + mUnions + mAliases + (Dict.insert identity name (Value comment tipe) mValues) + mBinops + ) + ) + ) + + +getComment : A.Region -> Name.Name -> Info -> Result.RResult i w E.DefProblem Comment +getComment region name (Info iComments _ _ _ _ _) = + case Dict.get identity name iComments of + Nothing -> + Result.throw (E.NoComment name region) + + Just (Src.Comment snippet) -> + Result.ok (Json.fromComment snippet) + + +getType : Name.Name -> Info -> Result.RResult i w E.DefProblem Type.Type +getType name (Info _ iValues _ _ _ _) = + case Utils.find identity name iValues of + Err region -> + Result.throw (E.NoAnnotation name region) + + Ok tipe -> + Result.ok (Extract.fromType tipe) + + +dector : Can.Ctor -> ( Name, List Type.Type ) +dector (Can.Ctor name _ _ args) = + ( name, List.map Extract.fromType args ) + + + +-- GATHER TYPES + + +type alias Types = + Dict String Name.Name (Result A.Region Can.Type) + + +gatherTypes : Can.Decls -> Types -> Types +gatherTypes decls types = + case decls of + Can.Declare def subDecls -> + gatherTypes subDecls (addDef types def) + + Can.DeclareRec def defs subDecls -> + gatherTypes subDecls (List.foldl (flip addDef) (addDef types def) defs) + + Can.SaveTheEnvironment -> + types + + +addDef : Types -> Can.Def -> Types +addDef types def = + case def of + Can.Def (A.At region name) _ _ -> + Dict.insert identity name (Err region) types + + Can.TypedDef (A.At _ name) _ typedArgs _ resultType -> + let + tipe : Can.Type + tipe = + List.foldr Can.TLambda resultType (List.map Tuple.second typedArgs) + in + Dict.insert identity name (Ok tipe) types + + + +-- JSON ENCODERS and DECODERS + + +jsonEncoder : Documentation -> Encode.Value +jsonEncoder = + E.toJsonValue << encode + + +jsonDecoder : Decode.Decoder Documentation +jsonDecoder = + Decode.map toDict (Decode.list jsonModuleDecoder) + + +jsonModuleEncoder : Module -> Encode.Value +jsonModuleEncoder (Module name comment unions aliases values binops) = + Encode.object + [ ( "name", Encode.string name ) + , ( "comment", Encode.string comment ) + , ( "unions", E.assocListDict compare Encode.string jsonUnionEncoder unions ) + , ( "aliases", E.assocListDict compare Encode.string jsonAliasEncoder aliases ) + , ( "values", E.assocListDict compare Encode.string jsonValueEncoder values ) + , ( "binops", E.assocListDict compare Encode.string jsonBinopEncoder binops ) + ] + + +jsonModuleDecoder : Decode.Decoder Module +jsonModuleDecoder = + Decode.map6 Module + (Decode.field "name" Decode.string) + (Decode.field "comment" Decode.string) + (Decode.field "unions" (D.assocListDict identity Decode.string jsonUnionDecoder)) + (Decode.field "aliases" (D.assocListDict identity Decode.string jsonAliasDecoder)) + (Decode.field "values" (D.assocListDict identity Decode.string jsonValueDecoder)) + (Decode.field "binops" (D.assocListDict identity Decode.string jsonBinopDecoder)) + + +jsonUnionEncoder : Union -> Encode.Value +jsonUnionEncoder (Union comment args cases) = + Encode.object + [ ( "comment", Encode.string comment ) + , ( "args", Encode.list Encode.string args ) + , ( "cases", Encode.list (E.jsonPair Encode.string (Encode.list Type.jsonEncoder)) cases ) + ] + + +jsonUnionDecoder : Decode.Decoder Union +jsonUnionDecoder = + Decode.map3 Union + (Decode.field "comment" Decode.string) + (Decode.field "args" (Decode.list Decode.string)) + (Decode.field "cases" (Decode.list (D.jsonPair Decode.string (Decode.list Type.jsonDecoder)))) + + +jsonAliasEncoder : Alias -> Encode.Value +jsonAliasEncoder (Alias comment args type_) = + Encode.object + [ ( "comment", Encode.string comment ) + , ( "args", Encode.list Encode.string args ) + , ( "type", Type.jsonEncoder type_ ) + ] + + +jsonAliasDecoder : Decode.Decoder Alias +jsonAliasDecoder = + Decode.map3 Alias + (Decode.field "comment" Decode.string) + (Decode.field "args" (Decode.list Decode.string)) + (Decode.field "type" Type.jsonDecoder) + + +jsonValueEncoder : Value -> Encode.Value +jsonValueEncoder (Value comment type_) = + Encode.object + [ ( "comment", Encode.string comment ) + , ( "type", Type.jsonEncoder type_ ) + ] + + +jsonValueDecoder : Decode.Decoder Value +jsonValueDecoder = + Decode.map2 Value + (Decode.field "comment" Decode.string) + (Decode.field "type" Type.jsonDecoder) + + +jsonBinopEncoder : Binop -> Encode.Value +jsonBinopEncoder (Binop comment type_ associativity precedence) = + Encode.object + [ ( "comment", Encode.string comment ) + , ( "type", Type.jsonEncoder type_ ) + , ( "associativity", Binop.jsonAssociativityEncoder associativity ) + , ( "precedence", Binop.jsonPrecedenceEncoder precedence ) + ] + + +jsonBinopDecoder : Decode.Decoder Binop +jsonBinopDecoder = + Decode.map4 Binop + (Decode.field "comment" Decode.string) + (Decode.field "type" Type.jsonDecoder) + (Decode.field "associativity" Binop.jsonAssociativityDecoder) + (Decode.field "precedence" Binop.jsonPrecedenceDecoder) + + + +-- ENCODERS and DECODERS + + +bytesEncoder : Documentation -> BE.Encoder +bytesEncoder docs = + BE.list bytesModuleEncoder (Dict.values compare docs) + + +bytesDecoder : BD.Decoder Documentation +bytesDecoder = + BD.map toDict (BD.list bytesModuleDecoder) + + +bytesModuleEncoder : Module -> BE.Encoder +bytesModuleEncoder (Module name comment unions aliases values binops) = + BE.sequence + [ BE.string name + , BE.string comment + , BE.assocListDict compare BE.string bytesUnionEncoder unions + , BE.assocListDict compare BE.string bytesAliasEncoder aliases + , BE.assocListDict compare BE.string bytesValueEncoder values + , BE.assocListDict compare BE.string bytesBinopEncoder binops + ] + + +bytesModuleDecoder : BD.Decoder Module +bytesModuleDecoder = + BD.map6 Module + BD.string + BD.string + (BD.assocListDict identity BD.string bytesUnionDecoder) + (BD.assocListDict identity BD.string bytesAliasDecoder) + (BD.assocListDict identity BD.string bytesValueDecoder) + (BD.assocListDict identity BD.string bytesBinopDecoder) + + +bytesUnionEncoder : Union -> BE.Encoder +bytesUnionEncoder (Union comment args cases) = + BE.sequence + [ BE.string comment + , BE.list BE.string args + , BE.list (BE.jsonPair BE.string (BE.list Type.bytesEncoder)) cases + ] + + +bytesUnionDecoder : BD.Decoder Union +bytesUnionDecoder = + BD.map3 Union + BD.string + (BD.list BD.string) + (BD.list (BD.jsonPair BD.string (BD.list Type.bytesDecoder))) + + +bytesAliasEncoder : Alias -> BE.Encoder +bytesAliasEncoder (Alias comment args type_) = + BE.sequence + [ BE.string comment + , BE.list BE.string args + , Type.bytesEncoder type_ + ] + + +bytesAliasDecoder : BD.Decoder Alias +bytesAliasDecoder = + BD.map3 Alias + BD.string + (BD.list BD.string) + Type.bytesDecoder + + +bytesValueEncoder : Value -> BE.Encoder +bytesValueEncoder (Value comment type_) = + BE.sequence + [ BE.string comment + , Type.bytesEncoder type_ + ] + + +bytesValueDecoder : BD.Decoder Value +bytesValueDecoder = + BD.map2 Value + BD.string + Type.bytesDecoder + + +bytesBinopEncoder : Binop -> BE.Encoder +bytesBinopEncoder (Binop comment type_ associativity precedence) = + BE.sequence + [ BE.string comment + , Type.bytesEncoder type_ + , Binop.associativityEncoder associativity + , Binop.precedenceEncoder precedence + ] + + +bytesBinopDecoder : BD.Decoder Binop +bytesBinopDecoder = + BD.map4 Binop + BD.string + Type.bytesDecoder + Binop.associativityDecoder + Binop.precedenceDecoder diff --git a/src/Compiler/Elm/Interface.elm b/src/Compiler/Elm/Interface.elm new file mode 100644 index 0000000000..fce88fa3b0 --- /dev/null +++ b/src/Compiler/Elm/Interface.elm @@ -0,0 +1,359 @@ +module Compiler.Elm.Interface exposing + ( Alias(..) + , Binop(..) + , DependencyInterface(..) + , Interface(..) + , Union(..) + , dependencyInterfaceDecoder + , dependencyInterfaceEncoder + , extractAlias + , extractUnion + , fromModule + , interfaceDecoder + , interfaceEncoder + , private + , privatize + , public + , toPublicAlias + , toPublicUnion + ) + +import Compiler.AST.Canonical as Can +import Compiler.AST.Utils.Binop as Binop +import Compiler.Data.Name as Name +import Compiler.Elm.Package as Pkg +import Compiler.Reporting.Annotation as A +import Data.Map as Dict exposing (Dict) +import Utils.Bytes.Decode as BD +import Utils.Bytes.Encode as BE +import Utils.Crash exposing (crash) +import Utils.Main as Utils + + + +-- INTERFACE + + +type Interface + = Interface Pkg.Name (Dict String Name.Name Can.Annotation) (Dict String Name.Name Union) (Dict String Name.Name Alias) (Dict String Name.Name Binop) + + +type Union + = OpenUnion Can.Union + | ClosedUnion Can.Union + | PrivateUnion Can.Union + + +type Alias + = PublicAlias Can.Alias + | PrivateAlias Can.Alias + + +type Binop + = Binop Name.Name Can.Annotation Binop.Associativity Binop.Precedence + + + +-- FROM MODULE + + +fromModule : Pkg.Name -> Can.Module -> Dict String Name.Name Can.Annotation -> Interface +fromModule home (Can.Module _ exports _ _ unions aliases binops _) annotations = + Interface home + (restrict exports annotations) + (restrictUnions exports unions) + (restrictAliases exports aliases) + (restrict exports (Dict.map (\_ -> toOp annotations) binops)) + + +restrict : Can.Exports -> Dict String Name.Name a -> Dict String Name.Name a +restrict exports dict = + case exports of + Can.ExportEverything _ -> + dict + + Can.Export explicitExports -> + Dict.intersection compare dict explicitExports + + +toOp : Dict String Name.Name Can.Annotation -> Can.Binop -> Binop +toOp types (Can.Binop_ associativity precedence name) = + Binop name (Utils.find identity name types) associativity precedence + + +restrictUnions : Can.Exports -> Dict String Name.Name Can.Union -> Dict String Name.Name Union +restrictUnions exports unions = + case exports of + Can.ExportEverything _ -> + Dict.map (\_ -> OpenUnion) unions + + Can.Export explicitExports -> + Dict.merge compare + (\_ _ result -> result) + (\k (A.At _ export) union result -> + case export of + Can.ExportUnionOpen -> + Dict.insert identity k (OpenUnion union) result + + Can.ExportUnionClosed -> + Dict.insert identity k (ClosedUnion union) result + + _ -> + crash "impossible exports discovered in restrictUnions" + ) + (\k union result -> Dict.insert identity k (PrivateUnion union) result) + explicitExports + unions + Dict.empty + + +restrictAliases : Can.Exports -> Dict String Name.Name Can.Alias -> Dict String Name.Name Alias +restrictAliases exports aliases = + case exports of + Can.ExportEverything _ -> + Dict.map (\_ alias -> PublicAlias alias) aliases + + Can.Export explicitExports -> + Dict.merge compare + (\_ _ result -> result) + (\k _ alias result -> Dict.insert identity k (PublicAlias alias) result) + (\k alias result -> Dict.insert identity k (PrivateAlias alias) result) + explicitExports + aliases + Dict.empty + + + +-- TO PUBLIC + + +toPublicUnion : Union -> Maybe Can.Union +toPublicUnion iUnion = + case iUnion of + OpenUnion union -> + Just union + + ClosedUnion (Can.Union vars _ _ opts) -> + Just (Can.Union vars [] 0 opts) + + PrivateUnion _ -> + Nothing + + +toPublicAlias : Alias -> Maybe Can.Alias +toPublicAlias iAlias = + case iAlias of + PublicAlias alias -> + Just alias + + PrivateAlias _ -> + Nothing + + + +-- DEPENDENCY INTERFACE + + +type DependencyInterface + = Public Interface + | Private Pkg.Name (Dict String Name.Name Can.Union) (Dict String Name.Name Can.Alias) + + +public : Interface -> DependencyInterface +public = + Public + + +private : Interface -> DependencyInterface +private (Interface pkg _ unions aliases _) = + Private pkg (Dict.map (\_ -> extractUnion) unions) (Dict.map (\_ -> extractAlias) aliases) + + +extractUnion : Union -> Can.Union +extractUnion iUnion = + case iUnion of + OpenUnion union -> + union + + ClosedUnion union -> + union + + PrivateUnion union -> + union + + +extractAlias : Alias -> Can.Alias +extractAlias iAlias = + case iAlias of + PublicAlias alias -> + alias + + PrivateAlias alias -> + alias + + +privatize : DependencyInterface -> DependencyInterface +privatize di = + case di of + Public i -> + private i + + Private _ _ _ -> + di + + + +-- ENCODERS and DECODERS + + +interfaceEncoder : Interface -> BE.Encoder +interfaceEncoder (Interface home values unions aliases binops) = + BE.sequence + [ Pkg.nameEncoder home + , BE.assocListDict compare BE.string Can.annotationEncoder values + , BE.assocListDict compare BE.string unionEncoder unions + , BE.assocListDict compare BE.string aliasEncoder aliases + , BE.assocListDict compare BE.string binopEncoder binops + ] + + +interfaceDecoder : BD.Decoder Interface +interfaceDecoder = + BD.map5 Interface + Pkg.nameDecoder + (BD.assocListDict identity BD.string Can.annotationDecoder) + (BD.assocListDict identity BD.string unionDecoder) + (BD.assocListDict identity BD.string aliasDecoder) + (BD.assocListDict identity BD.string binopDecoder) + + +unionEncoder : Union -> BE.Encoder +unionEncoder union_ = + case union_ of + OpenUnion union -> + BE.sequence + [ BE.unsignedInt8 0 + , Can.unionEncoder union + ] + + ClosedUnion union -> + BE.sequence + [ BE.unsignedInt8 1 + , Can.unionEncoder union + ] + + PrivateUnion union -> + BE.sequence + [ BE.unsignedInt8 2 + , Can.unionEncoder union + ] + + +unionDecoder : BD.Decoder Union +unionDecoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.map OpenUnion Can.unionDecoder + + 1 -> + BD.map ClosedUnion Can.unionDecoder + + 2 -> + BD.map PrivateUnion Can.unionDecoder + + _ -> + BD.fail + ) + + +aliasEncoder : Alias -> BE.Encoder +aliasEncoder aliasValue = + case aliasValue of + PublicAlias alias_ -> + BE.sequence + [ BE.unsignedInt8 0 + , Can.aliasEncoder alias_ + ] + + PrivateAlias alias_ -> + BE.sequence + [ BE.unsignedInt8 1 + , Can.aliasEncoder alias_ + ] + + +aliasDecoder : BD.Decoder Alias +aliasDecoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.map PublicAlias Can.aliasDecoder + + 1 -> + BD.map PrivateAlias Can.aliasDecoder + + _ -> + BD.fail + ) + + +binopEncoder : Binop -> BE.Encoder +binopEncoder (Binop name annotation associativity precedence) = + BE.sequence + [ BE.string name + , Can.annotationEncoder annotation + , Binop.associativityEncoder associativity + , Binop.precedenceEncoder precedence + ] + + +binopDecoder : BD.Decoder Binop +binopDecoder = + BD.map4 Binop + BD.string + Can.annotationDecoder + Binop.associativityDecoder + Binop.precedenceDecoder + + +dependencyInterfaceEncoder : DependencyInterface -> BE.Encoder +dependencyInterfaceEncoder dependencyInterface = + case dependencyInterface of + Public i -> + BE.sequence + [ BE.unsignedInt8 0 + , interfaceEncoder i + ] + + Private pkg unions aliases -> + BE.sequence + [ BE.unsignedInt8 1 + , Pkg.nameEncoder pkg + , BE.assocListDict compare BE.string Can.unionEncoder unions + , BE.assocListDict compare BE.string Can.aliasEncoder aliases + ] + + +dependencyInterfaceDecoder : BD.Decoder DependencyInterface +dependencyInterfaceDecoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.map Public interfaceDecoder + + 1 -> + BD.map3 Private + Pkg.nameDecoder + (BD.assocListDict identity BD.string Can.unionDecoder) + (BD.assocListDict identity BD.string Can.aliasDecoder) + + _ -> + BD.fail + ) diff --git a/src/Compiler/Elm/Kernel.elm b/src/Compiler/Elm/Kernel.elm new file mode 100644 index 0000000000..0b1bfdcefd --- /dev/null +++ b/src/Compiler/Elm/Kernel.elm @@ -0,0 +1,504 @@ +module Compiler.Elm.Kernel exposing + ( Chunk(..) + , Content(..) + , Foreigns + , chunkDecoder + , chunkEncoder + , countFields + , fromByteString + ) + +import Compiler.AST.Source as Src +import Compiler.Data.Name as Name exposing (Name) +import Compiler.Elm.ModuleName as ModuleName +import Compiler.Elm.Package as Pkg +import Compiler.Parse.Module as Module +import Compiler.Parse.Primitives as P exposing (Col, Row) +import Compiler.Parse.Space as Space +import Compiler.Parse.Variable as Var +import Compiler.Reporting.Annotation as A +import Data.Map as Dict exposing (Dict) +import System.TypeCheck.IO as IO +import Utils.Bytes.Decode as BD +import Utils.Bytes.Encode as BE +import Utils.Crash exposing (crash) + + + +-- CHUNK + + +type Chunk + = JS String + | ElmVar IO.Canonical Name + | JsVar Name Name + | ElmField Name + | JsField Int + | JsEnum Int + | Debug + | Prod + + + +-- COUNT FIELDS + + +countFields : List Chunk -> Dict String Name Int +countFields chunks = + List.foldr addField Dict.empty chunks + + +addField : Chunk -> Dict String Name Int -> Dict String Name Int +addField chunk fields = + case chunk of + JS _ -> + fields + + ElmVar _ _ -> + fields + + JsVar _ _ -> + fields + + ElmField f -> + Dict.update identity + f + (Maybe.map ((+) 1) + >> Maybe.withDefault 1 + >> Just + ) + fields + + JsField _ -> + fields + + JsEnum _ -> + fields + + Debug -> + fields + + Prod -> + fields + + + +-- FROM FILE + + +type Content + = Content (List (Src.C1 Src.Import)) (List Chunk) + + +type alias Foreigns = + Dict String ModuleName.Raw Pkg.Name + + +fromByteString : Pkg.Name -> Foreigns -> String -> Maybe Content +fromByteString pkg foreigns bytes = + case P.fromByteString (parser pkg foreigns) toError bytes of + Ok content -> + Just content + + Err () -> + Nothing + + +parser : Pkg.Name -> Foreigns -> P.Parser () Content +parser pkg foreigns = + P.word2 '/' '*' toError + |> P.bind (\_ -> Space.chomp ignoreError) + |> P.bind (\_ -> Space.checkFreshLine toError) + |> P.bind (\_ -> P.specialize ignoreError (Module.chompImports [])) + |> P.bind + (\imports -> + P.word2 '*' '/' toError + |> P.bind (\_ -> parseChunks (toVarTable pkg foreigns imports) Dict.empty Dict.empty) + |> P.fmap (\chunks -> Content imports chunks) + ) + + +toError : Row -> Col -> () +toError _ _ = + () + + +ignoreError : a -> Row -> Col -> () +ignoreError _ _ _ = + () + + + +-- PARSE CHUNKS + + +parseChunks : VarTable -> Enums -> Fields -> P.Parser () (List Chunk) +parseChunks vtable enums fields = + P.Parser + (\(P.State src pos end indent row col) -> + let + ( ( chunks, newPos ), ( newRow, newCol ) ) = + chompChunks vtable enums fields src pos end row col pos [] + in + if newPos == end then + P.Cok chunks (P.State src newPos end indent newRow newCol) + + else + P.Cerr row col toError + ) + + +chompChunks : VarTable -> Enums -> Fields -> String -> Int -> Int -> Row -> Col -> Int -> List Chunk -> ( ( List Chunk, Int ), ( Row, Col ) ) +chompChunks vs es fs src pos end row col lastPos revChunks = + if pos >= end then + let + js : String + js = + toByteString src lastPos end + in + ( ( List.reverse (JS js :: revChunks), pos ), ( row, col ) ) + + else + let + word : Char + word = + P.unsafeIndex src pos + in + if word == '_' then + let + pos1 : Int + pos1 = + pos + 1 + + pos3 : Int + pos3 = + pos + 3 + in + if pos3 <= end && P.unsafeIndex src pos1 == '_' then + let + js : String + js = + toByteString src lastPos pos + in + chompTag vs es fs src pos3 end row (col + 3) (JS js :: revChunks) + + else + chompChunks vs es fs src pos1 end row (col + 1) lastPos revChunks + + else if word == '\n' then + chompChunks vs es fs src (pos + 1) end (row + 1) 1 lastPos revChunks + + else + let + newPos : Int + newPos = + pos + P.getCharWidth word + in + chompChunks vs es fs src newPos end row (col + 1) lastPos revChunks + + +type alias Enums = + Dict Int Int (Dict String Name Int) + + +type alias Fields = + Dict String Name Int + + +toByteString : String -> Int -> Int -> String +toByteString src pos end = + let + off : Int + off = + -- pos - unsafeForeignPtrToPtr src + pos + + len : Int + len = + end - pos + in + String.slice off (off + len) src + + +chompTag : VarTable -> Enums -> Fields -> String -> Int -> Int -> Row -> Col -> List Chunk -> ( ( List Chunk, Int ), ( Row, Col ) ) +chompTag vs es fs src pos end row col revChunks = + let + ( newPos, newCol ) = + Var.chompInnerChars src pos end col + + tagPos : Int + tagPos = + pos + -1 + + word : Char + word = + P.unsafeIndex src tagPos + in + if word == '$' then + let + name : Name + name = + Name.fromPtr src pos newPos + in + chompChunks vs es fs src newPos end row newCol newPos <| + (ElmField name :: revChunks) + + else + let + name : Name + name = + Name.fromPtr src tagPos newPos + + code : Int + code = + Char.toCode word + in + if code >= 0x30 && code <= 0x39 then + let + ( enum, newEnums ) = + lookupEnum (Char.fromCode (code - 0x30)) name es + in + chompChunks vs newEnums fs src newPos end row newCol newPos <| + (JsEnum enum :: revChunks) + + else if code >= 0x61 && code <= 0x7A then + let + ( field, newFields ) = + lookupField name fs + in + chompChunks vs es newFields src newPos end row newCol newPos <| + (JsField field :: revChunks) + + else if name == "DEBUG" then + chompChunks vs es fs src newPos end row newCol newPos (Debug :: revChunks) + + else if name == "PROD" then + chompChunks vs es fs src newPos end row newCol newPos (Prod :: revChunks) + + else + case Dict.get identity name vs of + Just chunk -> + chompChunks vs es fs src newPos end row newCol newPos (chunk :: revChunks) + + Nothing -> + ( ( revChunks, pos ), ( row, col ) ) + + +lookupField : Name -> Fields -> ( Int, Fields ) +lookupField name fields = + case Dict.get identity name fields of + Just n -> + ( n, fields ) + + Nothing -> + let + n : Int + n = + Dict.size fields + in + ( n, Dict.insert identity name n fields ) + + +lookupEnum : Char -> Name -> Enums -> ( Int, Enums ) +lookupEnum word var allEnums = + let + code : Int + code = + Char.toCode word + + enums : Dict String Name Int + enums = + Dict.get identity code allEnums + |> Maybe.withDefault Dict.empty + in + case Dict.get identity var enums of + Just n -> + ( n, allEnums ) + + Nothing -> + let + n : Int + n = + Dict.size enums + in + ( n, Dict.insert identity code (Dict.insert identity var n enums) allEnums ) + + + +-- PROCESS IMPORTS + + +type alias VarTable = + Dict String Name Chunk + + +toVarTable : Pkg.Name -> Foreigns -> List (Src.C1 Src.Import) -> VarTable +toVarTable pkg foreigns imports = + List.foldl (addImport pkg foreigns) Dict.empty imports + + +addImport : Pkg.Name -> Foreigns -> Src.C1 Src.Import -> VarTable -> VarTable +addImport pkg foreigns ( _, Src.Import ( _, A.At _ importName ) maybeAlias ( _, exposing_ ) ) vtable = + if Name.isKernel importName then + case maybeAlias of + Just _ -> + crash ("cannot use `as` with kernel import of: " ++ importName) + + Nothing -> + let + home : Name + home = + Name.getKernel importName + + add : Name -> Dict String Name Chunk -> Dict String Name Chunk + add name table = + Dict.insert identity (Name.sepBy '_' home name) (JsVar home name) table + in + List.foldl add vtable (toNames exposing_) + + else + let + home : IO.Canonical + home = + IO.Canonical (Dict.get identity importName foreigns |> Maybe.withDefault pkg) importName + + prefix : Name + prefix = + toPrefix importName (Maybe.map Src.c2Value maybeAlias) + + add : Name -> Dict String Name Chunk -> Dict String Name Chunk + add name table = + Dict.insert identity (Name.sepBy '_' prefix name) (ElmVar home name) table + in + List.foldl add vtable (toNames exposing_) + + +toPrefix : Name -> Maybe Name -> Name +toPrefix home maybeAlias = + case maybeAlias of + Just alias -> + alias + + Nothing -> + if Name.hasDot home then + crash ("kernel imports with dots need an alias: " ++ home) + + else + home + + +toNames : Src.Exposing -> List Name +toNames exposing_ = + case exposing_ of + Src.Open _ _ -> + crash "cannot have `exposing (..)` in kernel code." + + Src.Explicit (A.At _ exposedList) -> + List.map (Src.c2Value >> toName) exposedList + + +toName : Src.Exposed -> Name +toName exposed = + case exposed of + Src.Lower (A.At _ name) -> + name + + Src.Upper (A.At _ name) ( _, Src.Private ) -> + name + + Src.Upper _ ( _, Src.Public _ ) -> + crash "cannot have Maybe(..) syntax in kernel code header" + + Src.Operator _ _ -> + crash "cannot use binops in kernel code" + + + +-- ENCODERS and DECODERS + + +chunkEncoder : Chunk -> BE.Encoder +chunkEncoder chunk = + case chunk of + JS javascript -> + BE.sequence + [ BE.unsignedInt8 0 + , BE.string javascript + ] + + ElmVar home name -> + BE.sequence + [ BE.unsignedInt8 1 + , ModuleName.canonicalEncoder home + , BE.string name + ] + + JsVar home name -> + BE.sequence + [ BE.unsignedInt8 2 + , BE.string home + , BE.string name + ] + + ElmField name -> + BE.sequence + [ BE.unsignedInt8 3 + , BE.string name + ] + + JsField int -> + BE.sequence + [ BE.unsignedInt8 4 + , BE.int int + ] + + JsEnum int -> + BE.sequence + [ BE.unsignedInt8 5 + , BE.int int + ] + + Debug -> + BE.unsignedInt8 6 + + Prod -> + BE.unsignedInt8 7 + + +chunkDecoder : BD.Decoder Chunk +chunkDecoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.map JS BD.string + + 1 -> + BD.map2 ElmVar + ModuleName.canonicalDecoder + BD.string + + 2 -> + BD.map2 JsVar + BD.string + BD.string + + 3 -> + BD.map ElmField BD.string + + 4 -> + BD.map JsField BD.int + + 5 -> + BD.map JsEnum BD.int + + 6 -> + BD.succeed Debug + + 7 -> + BD.succeed Prod + + _ -> + BD.fail + ) diff --git a/src/Compiler/Elm/Licenses.elm b/src/Compiler/Elm/Licenses.elm new file mode 100644 index 0000000000..ef291c10b9 --- /dev/null +++ b/src/Compiler/Elm/Licenses.elm @@ -0,0 +1,176 @@ +module Compiler.Elm.Licenses exposing + ( License + , bsd3 + , decoder + , encode + ) + +import Compiler.Json.Decode as D +import Compiler.Json.Encode as E +import Compiler.Reporting.Suggest as Suggest +import Data.Map as Dict exposing (Dict) + + + +-- LICENSES + + +type License + = License String + + +bsd3 : License +bsd3 = + License "BSD-3-Clause" + + +encode : License -> E.Value +encode (License code) = + E.string code + + +decoder : (List String -> x) -> D.Decoder x License +decoder toError = + D.string + |> D.bind + (\str -> + case check str of + Ok license -> + D.pure license + + Err suggestions -> + D.failure (toError suggestions) + ) + + + +-- CHECK + + +check : String -> Result (List String) License +check givenCode = + if Dict.member identity givenCode osiApprovedSpdxLicenses then + Ok (License givenCode) + + else + let + pairs : List ( String, String ) + pairs = + List.map (\code -> ( code, code )) (Dict.keys compare osiApprovedSpdxLicenses) + ++ Dict.toList compare osiApprovedSpdxLicenses + in + Err + (List.map Tuple.first + (List.take 4 + (Suggest.sort givenCode Tuple.second pairs) + ) + ) + + + +-- LIST OF LICENSES + + +osiApprovedSpdxLicenses : Dict String String String +osiApprovedSpdxLicenses = + Dict.fromList identity + [ ( "0BSD", "BSD Zero Clause License" ) + , ( "AAL", "Attribution Assurance License" ) + , ( "AFL-1.1", "Academic Free License v1.1" ) + , ( "AFL-1.2", "Academic Free License v1.2" ) + , ( "AFL-2.0", "Academic Free License v2.0" ) + , ( "AFL-2.1", "Academic Free License v2.1" ) + , ( "AFL-3.0", "Academic Free License v3.0" ) + , ( "AGPL-3.0", "GNU Affero General Public License v3.0" ) + , ( "Apache-1.1", "Apache License 1.1" ) + , ( "Apache-2.0", "Apache License 2.0" ) + , ( "APL-1.0", "Adaptive Public License 1.0" ) + , ( "APSL-1.0", "Apple Public Source License 1.0" ) + , ( "APSL-1.1", "Apple Public Source License 1.1" ) + , ( "APSL-1.2", "Apple Public Source License 1.2" ) + , ( "APSL-2.0", "Apple Public Source License 2.0" ) + , ( "Artistic-1.0", "Artistic License 1.0" ) + , ( "Artistic-1.0-cl8", "Artistic License 1.0 w/clause 8" ) + , ( "Artistic-1.0-Perl", "Artistic License 1.0 (Perl)" ) + , ( "Artistic-2.0", "Artistic License 2.0" ) + , ( "BSD-2-Clause", "BSD 2-clause \"Simplified\" License" ) + , ( "BSD-3-Clause", "BSD 3-clause \"New\" or \"Revised\" License" ) + , ( "BSL-1.0", "Boost Software License 1.0" ) + , ( "CATOSL-1.1", "Computer Associates Trusted Open Source License 1.1" ) + , ( "CDDL-1.0", "Common Development and Distribution License 1.0" ) + , ( "CECILL-2.1", "CeCILL Free Software License Agreement v2.1" ) + , ( "CNRI-Python", "CNRI Python License" ) + , ( "CPAL-1.0", "Common Public Attribution License 1.0" ) + , ( "CPL-1.0", "Common Public License 1.0" ) + , ( "CUA-OPL-1.0", "CUA Office Public License v1.0" ) + , ( "ECL-1.0", "Educational Community License v1.0" ) + , ( "ECL-2.0", "Educational Community License v2.0" ) + , ( "EFL-1.0", "Eiffel Forum License v1.0" ) + , ( "EFL-2.0", "Eiffel Forum License v2.0" ) + , ( "Entessa", "Entessa Public License v1.0" ) + , ( "EPL-1.0", "Eclipse Public License 1.0" ) + , ( "EUDatagrid", "EU DataGrid Software License" ) + , ( "EUPL-1.1", "European Union Public License 1.1" ) + , ( "Fair", "Fair License" ) + , ( "Frameworx-1.0", "Frameworx Open License 1.0" ) + , ( "GPL-2.0", "GNU General Public License v2.0 only" ) + , ( "GPL-3.0", "GNU General Public License v3.0 only" ) + , ( "HPND", "Historic Permission Notice and Disclaimer" ) + , ( "Intel", "Intel Open Source License" ) + , ( "IPA", "IPA Font License" ) + , ( "IPL-1.0", "IBM Public License v1.0" ) + , ( "ISC", "ISC License" ) + , ( "LGPL-2.0", "GNU Library General Public License v2 only" ) + , ( "LGPL-2.1", "GNU Lesser General Public License v2.1 only" ) + , ( "LGPL-3.0", "GNU Lesser General Public License v3.0 only" ) + , ( "LiLiQ-P-1.1", "Licence Libre du Québec – Permissive version 1.1" ) + , ( "LiLiQ-R-1.1", "Licence Libre du Québec – Réciprocité version 1.1" ) + , ( "LiLiQ-Rplus-1.1", "Licence Libre du Québec – Réciprocité forte version 1.1" ) + , ( "LPL-1.0", "Lucent Public License Version 1.0" ) + , ( "LPL-1.02", "Lucent Public License v1.02" ) + , ( "LPPL-1.3c", "LaTeX Project Public License v1.3c" ) + , ( "MirOS", "MirOS Licence" ) + , ( "MIT", "MIT License" ) + , ( "Motosoto", "Motosoto License" ) + , ( "MPL-1.0", "Mozilla Public License 1.0" ) + , ( "MPL-1.1", "Mozilla Public License 1.1" ) + , ( "MPL-2.0", "Mozilla Public License 2.0" ) + , ( "MPL-2.0-no-copyleft-exception", "Mozilla Public License 2.0 (no copyleft exception)" ) + , ( "MS-PL", "Microsoft Public License" ) + , ( "MS-RL", "Microsoft Reciprocal License" ) + , ( "Multics", "Multics License" ) + , ( "NASA-1.3", "NASA Open Source Agreement 1.3" ) + , ( "Naumen", "Naumen Public License" ) + , ( "NCSA", "University of Illinois/NCSA Open Source License" ) + , ( "NGPL", "Nethack General Public License" ) + , ( "Nokia", "Nokia Open Source License" ) + , ( "NPOSL-3.0", "Non-Profit Open Software License 3.0" ) + , ( "NTP", "NTP License" ) + , ( "OCLC-2.0", "OCLC Research Public License 2.0" ) + , ( "OFL-1.1", "SIL Open Font License 1.1" ) + , ( "OGTSL", "Open Group Test Suite License" ) + , ( "OSET-PL-2.1", "OSET Public License version 2.1" ) + , ( "OSL-1.0", "Open Software License 1.0" ) + , ( "OSL-2.0", "Open Software License 2.0" ) + , ( "OSL-2.1", "Open Software License 2.1" ) + , ( "OSL-3.0", "Open Software License 3.0" ) + , ( "PHP-3.0", "PHP License v3.0" ) + , ( "PostgreSQL", "PostgreSQL License" ) + , ( "Python-2.0", "Python License 2.0" ) + , ( "QPL-1.0", "Q Public License 1.0" ) + , ( "RPL-1.1", "Reciprocal Public License 1.1" ) + , ( "RPL-1.5", "Reciprocal Public License 1.5" ) + , ( "RPSL-1.0", "RealNetworks Public Source License v1.0" ) + , ( "RSCPL", "Ricoh Source Code Public License" ) + , ( "SimPL-2.0", "Simple Public License 2.0" ) + , ( "SISSL", "Sun Industry Standards Source License v1.1" ) + , ( "Sleepycat", "Sleepycat License" ) + , ( "SPL-1.0", "Sun Public License v1.0" ) + , ( "UPL-1.0", "Universal Permissive License v1.0" ) + , ( "VSL-1.0", "Vovida Software License v1.0" ) + , ( "W3C", "W3C Software Notice and License (2002-12-31)" ) + , ( "Watcom-1.0", "Sybase Open Watcom Public License 1.0" ) + , ( "Xnet", "X.Net License" ) + , ( "Zlib", "zlib License" ) + , ( "ZPL-2.0", "Zope Public License 2.0" ) + ] diff --git a/src/Compiler/Elm/Magnitude.elm b/src/Compiler/Elm/Magnitude.elm new file mode 100644 index 0000000000..1bbf549040 --- /dev/null +++ b/src/Compiler/Elm/Magnitude.elm @@ -0,0 +1,44 @@ +module Compiler.Elm.Magnitude exposing + ( Magnitude(..) + , compare + , toChars + ) + +-- MAGNITUDE + + +type Magnitude + = PATCH + | MINOR + | MAJOR + + +toChars : Magnitude -> String +toChars magnitude = + case magnitude of + PATCH -> + "PATCH" + + MINOR -> + "MINOR" + + MAJOR -> + "MAJOR" + + +compare : Magnitude -> Magnitude -> Order +compare m1 m2 = + let + toInt : Magnitude -> number + toInt m = + case m of + PATCH -> + 0 + + MINOR -> + 1 + + MAJOR -> + 2 + in + Basics.compare (toInt m1) (toInt m2) diff --git a/src/Compiler/Elm/ModuleName.elm b/src/Compiler/Elm/ModuleName.elm new file mode 100644 index 0000000000..f21184b72b --- /dev/null +++ b/src/Compiler/Elm/ModuleName.elm @@ -0,0 +1,345 @@ +module Compiler.Elm.ModuleName exposing + ( Raw + , array + , basics + , canonicalDecoder + , canonicalEncoder + , char + , cmd + , compareCanonical + , debug + , decoder + , dict + , encode + , jsonDecode + , jsonEncode + , list + , matrix4 + , maybe + , platform + , rawDecoder + , rawEncoder + , result + , string + , sub + , texture + , toChars + , toComparableCanonical + , toFilePath + , toHyphenPath + , tuple + , vector2 + , vector3 + , vector4 + , virtualDom + , webgl + ) + +import Compiler.Data.Name as Name exposing (Name) +import Compiler.Elm.Package as Pkg +import Compiler.Json.Decode as D +import Compiler.Json.Encode as E +import Compiler.Parse.Primitives as P +import Compiler.Parse.Variable as Var +import System.TypeCheck.IO exposing (Canonical(..)) +import Utils.Bytes.Decode as BD +import Utils.Bytes.Encode as BE + + + +-- RAW + + +type alias Raw = + Name + + +toChars : Raw -> List Char +toChars = + Name.toChars + + +toFilePath : Raw -> String +toFilePath name = + String.map + (\c -> + if c == '.' then + -- TODO System.FilePath.pathSeparator + '/' + + else + c + ) + name + + +toHyphenPath : Raw -> String +toHyphenPath name = + String.map + (\c -> + if c == '.' then + '-' + + else + c + ) + name + + + +-- JSON + + +encode : Raw -> E.Value +encode = + E.string + + +decoder : D.Decoder ( Int, Int ) Raw +decoder = + D.customString parser Tuple.pair + + + +-- PARSER + + +parser : P.Parser ( Int, Int ) Raw +parser = + P.Parser + (\(P.State src pos end indent row col) -> + let + ( isGood, newPos, newCol ) = + chompStart src pos end col + in + if isGood && (newPos - pos) < 256 then + let + newState : P.State + newState = + P.State src newPos end indent row newCol + in + P.Cok (String.slice pos newPos src) newState + + else if col == newCol then + P.Eerr row newCol Tuple.pair + + else + P.Cerr row newCol Tuple.pair + ) + + +chompStart : String -> Int -> Int -> Int -> ( Bool, Int, Int ) +chompStart src pos end col = + let + width : Int + width = + Var.getUpperWidth src pos end + in + if width == 0 then + ( False, pos, col ) + + else + chompInner src (pos + width) end (col + 1) + + +chompInner : String -> Int -> Int -> Int -> ( Bool, Int, Int ) +chompInner src pos end col = + if pos >= end then + ( True, pos, col ) + + else + let + word : Char + word = + P.unsafeIndex src pos + + width : Int + width = + Var.getInnerWidthHelp src pos end word + in + if width == 0 then + if word == '.' then + chompStart src (pos + 1) end (col + 1) + + else + ( True, pos, col ) + + else + chompInner src (pos + width) end (col + 1) + + + +-- INSTANCES + + +compareCanonical : Canonical -> Canonical -> Order +compareCanonical (Canonical pkg1 name1) (Canonical pkg2 name2) = + case compare name1 name2 of + LT -> + LT + + EQ -> + Pkg.compareName pkg1 pkg2 + + GT -> + GT + + +toComparableCanonical : Canonical -> List String +toComparableCanonical (Canonical ( author, project ) name) = + [ author, project, name ] + + + +-- CORE + + +basics : Canonical +basics = + Canonical Pkg.core Name.basics + + +char : Canonical +char = + Canonical Pkg.core Name.char + + +string : Canonical +string = + Canonical Pkg.core Name.string + + +maybe : Canonical +maybe = + Canonical Pkg.core Name.maybe + + +result : Canonical +result = + Canonical Pkg.core Name.result + + +list : Canonical +list = + Canonical Pkg.core Name.list + + +array : Canonical +array = + Canonical Pkg.core Name.array + + +dict : Canonical +dict = + Canonical Pkg.core Name.dict + + +tuple : Canonical +tuple = + Canonical Pkg.core Name.tuple + + +platform : Canonical +platform = + Canonical Pkg.core Name.platform + + +cmd : Canonical +cmd = + Canonical Pkg.core "Platform.Cmd" + + +sub : Canonical +sub = + Canonical Pkg.core "Platform.Sub" + + +debug : Canonical +debug = + Canonical Pkg.core Name.debug + + + +-- HTML + + +virtualDom : Canonical +virtualDom = + Canonical Pkg.virtualDom Name.virtualDom + + + +-- JSON + + +jsonDecode : Canonical +jsonDecode = + Canonical Pkg.json "Json.Decode" + + +jsonEncode : Canonical +jsonEncode = + Canonical Pkg.json "Json.Encode" + + + +-- WEBGL + + +webgl : Canonical +webgl = + Canonical Pkg.webgl "WebGL" + + +texture : Canonical +texture = + Canonical Pkg.webgl "WebGL.Texture" + + +vector2 : Canonical +vector2 = + Canonical Pkg.linearAlgebra "Math.Vector2" + + +vector3 : Canonical +vector3 = + Canonical Pkg.linearAlgebra "Math.Vector3" + + +vector4 : Canonical +vector4 = + Canonical Pkg.linearAlgebra "Math.Vector4" + + +matrix4 : Canonical +matrix4 = + Canonical Pkg.linearAlgebra "Math.Matrix4" + + + +-- ENCODERS and DECODERS + + +canonicalEncoder : Canonical -> BE.Encoder +canonicalEncoder (Canonical pkgName name) = + BE.sequence + [ Pkg.nameEncoder pkgName + , BE.string name + ] + + +canonicalDecoder : BD.Decoder Canonical +canonicalDecoder = + BD.map2 Canonical + Pkg.nameDecoder + BD.string + + +rawEncoder : Raw -> BE.Encoder +rawEncoder = + BE.string + + +rawDecoder : BD.Decoder Raw +rawDecoder = + BD.string diff --git a/src/Compiler/Elm/Package.elm b/src/Compiler/Elm/Package.elm new file mode 100644 index 0000000000..156818d848 --- /dev/null +++ b/src/Compiler/Elm/Package.elm @@ -0,0 +1,392 @@ +module Compiler.Elm.Package exposing + ( Author + , Name + , Project + , browser + , compareName + , core + , decoder + , dummyName + , encode + , html + , isKernel + , json + , kernel + , keyDecoder + , linearAlgebra + , nameDecoder + , nameEncoder + , nearbyNames + , parser + , random + , suggestions + , test + , time + , toChars + , toJsonString + , toString + , toUrl + , virtualDom + , webgl + ) + +import Compiler.Json.Decode as D +import Compiler.Json.Encode as E +import Compiler.Parse.Primitives as P exposing (Col, Row) +import Compiler.Reporting.Suggest as Suggest +import Data.Map as Dict exposing (Dict) +import Utils.Bytes.Decode as BD +import Utils.Bytes.Encode as BE + + + +-- PACKAGE NAMES + + +{-| This has been simplified from `Name Author Project` as part of the work for +`System.TypeCheck.IO`. +-} +type alias Name = + ( Author, Project ) + + +toString : Name -> String +toString ( author, project ) = + author ++ "/" ++ project + + +compareName : Name -> Name -> Order +compareName ( name1, project1 ) ( name2, project2 ) = + case compare name1 name2 of + LT -> + LT + + EQ -> + compare project1 project2 + + GT -> + GT + + +type alias Author = + String + + +type alias Project = + String + + + +-- HELPERS + + +isKernel : Name -> Bool +isKernel ( author, _ ) = + author == elm || author == elmExplorations + + +toChars : Name -> String +toChars ( author, project ) = + author ++ "/" ++ project + + +toUrl : Name -> String +toUrl ( author, project ) = + author ++ "/" ++ project + + +toJsonString : Name -> String +toJsonString ( author, project ) = + String.join "/" [ author, project ] + + + +-- COMMON PACKAGE NAMES + + +toName : Author -> Project -> Name +toName = + Tuple.pair + + +dummyName : Name +dummyName = + toName "author" "project" + + +kernel : Name +kernel = + toName elm "kernel" + + +core : Name +core = + toName elm "core" + + +browser : Name +browser = + toName elm "browser" + + +virtualDom : Name +virtualDom = + toName elm "virtual-dom" + + +html : Name +html = + toName elm "html" + + +json : Name +json = + toName elm "json" + + +http : Name +http = + toName elm "http" + + +random : Name +random = + toName elm "random" + + +time : Name +time = + toName elm "time" + + +url : Name +url = + toName elm "url" + + +webgl : Name +webgl = + toName elmExplorations "webgl" + + +linearAlgebra : Name +linearAlgebra = + toName elmExplorations "linear-algebra" + + +test : Name +test = + toName elmExplorations "test" + + +elm : Author +elm = + "elm" + + +elmExplorations : Author +elmExplorations = + "elm-explorations" + + + +-- PACKAGE SUGGESTIONS + + +suggestions : Dict String String Name +suggestions = + let + file : Name + file = + toName elm "file" + in + Dict.fromList identity + [ ( "Browser", browser ) + , ( "File", file ) + , ( "File.Download", file ) + , ( "File.Select", file ) + , ( "Html", html ) + , ( "Html.Attributes", html ) + , ( "Html.Events", html ) + , ( "Http", http ) + , ( "Json.Decode", json ) + , ( "Json.Encode", json ) + , ( "Random", random ) + , ( "Time", time ) + , ( "Url.Parser", url ) + , ( "Url", url ) + ] + + + +-- NEARBY NAMES + + +nearbyNames : Name -> List Name -> List Name +nearbyNames ( author1, project1 ) possibleNames = + let + authorDist : Author -> Int + authorDist = + authorDistance author1 + + projectDist : Project -> Int + projectDist = + projectDistance project1 + + nameDistance : Name -> Int + nameDistance ( author2, project2 ) = + authorDist author2 + projectDist project2 + in + List.take 4 (List.sortBy nameDistance possibleNames) + + +authorDistance : String -> Author -> Int +authorDistance given possibility = + if possibility == elm || possibility == elmExplorations then + 0 + + else + abs (Suggest.distance given possibility) + + +projectDistance : String -> Project -> Int +projectDistance given possibility = + abs (Suggest.distance given possibility) + + + +-- JSON + + +decoder : D.Decoder ( Row, Col ) Name +decoder = + D.customString parser Tuple.pair + + +encode : Name -> E.Value +encode name = + E.string (toChars name) + + +keyDecoder : (Row -> Col -> x) -> D.KeyDecoder x Name +keyDecoder toError = + let + keyParser : P.Parser x Name + keyParser = + P.specialize (\( r, c ) _ _ -> toError r c) parser + in + D.KeyDecoder keyParser toError + + + +-- PARSER + + +parser : P.Parser ( Row, Col ) Name +parser = + parseName isAlphaOrDigit isAlphaOrDigit + |> P.bind + (\author -> + P.word1 '/' Tuple.pair + |> P.bind (\_ -> parseName isLower isLowerOrDigit) + |> P.fmap + (\project -> ( author, project )) + ) + + +parseName : (Char -> Bool) -> (Char -> Bool) -> P.Parser ( Row, Col ) String +parseName isGoodStart isGoodInner = + P.Parser <| + \(P.State src pos end indent row col) -> + if pos >= end then + P.Eerr row col Tuple.pair + + else + let + word : Char + word = + P.unsafeIndex src pos + in + if not (isGoodStart word) then + P.Eerr row col Tuple.pair + + else + let + ( isGood, newPos ) = + chompName isGoodInner src (pos + 1) end False + + len : Int + len = + newPos - pos + + newCol : Col + newCol = + col + len + in + if isGood && len < 256 then + let + newState : P.State + newState = + P.State src newPos end indent row newCol + in + P.Cok (String.slice pos newPos src) newState + + else + P.Cerr row newCol Tuple.pair + + +isLower : Char -> Bool +isLower = + Char.isLower + + +isLowerOrDigit : Char -> Bool +isLowerOrDigit word = + Char.isLower word || Char.isDigit word + + +isAlphaOrDigit : Char -> Bool +isAlphaOrDigit = + Char.isAlphaNum + + +chompName : (Char -> Bool) -> String -> Int -> Int -> Bool -> ( Bool, Int ) +chompName isGoodChar src pos end prevWasDash = + if pos >= end then + ( not prevWasDash, pos ) + + else + let + word : Char + word = + P.unsafeIndex src pos + in + if isGoodChar word then + chompName isGoodChar src (pos + 1) end False + + else if word == '-' then + if prevWasDash then + ( False, pos ) + + else + chompName isGoodChar src (pos + 1) end True + + else + ( True, pos ) + + + +-- ENCODERS and DECODERS + + +nameEncoder : Name -> BE.Encoder +nameEncoder ( author, project ) = + BE.sequence + [ BE.string author + , BE.string project + ] + + +nameDecoder : BD.Decoder Name +nameDecoder = + BD.map2 Tuple.pair BD.string BD.string diff --git a/src/Compiler/Elm/String.elm b/src/Compiler/Elm/String.elm new file mode 100644 index 0000000000..37360e5629 --- /dev/null +++ b/src/Compiler/Elm/String.elm @@ -0,0 +1,80 @@ +module Compiler.Elm.String exposing + ( Chunk(..) + , fromChunks + ) + +import Hex +import Numeric.Integer as NI + + + +-- FROM CHUNKS + + +type Chunk + = Slice Int Int + | Escape Char + | CodePoint Int + + +fromChunks : String -> List Chunk -> String +fromChunks src chunks = + writeChunks src "" 0 chunks + + +writeChunks : String -> String -> Int -> List Chunk -> String +writeChunks src mba offset chunks = + case chunks of + [] -> + mba + + chunk :: otherChunks -> + case chunk of + Slice ptr len -> + let + newOffset : Int + newOffset = + offset + len + in + writeChunks src (mba ++ String.slice ptr (ptr + len) src) newOffset otherChunks + + Escape word -> + let + newOffset : Int + newOffset = + offset + 2 + in + writeChunks src (mba ++ "\\" ++ String.fromChar word) newOffset otherChunks + + CodePoint code -> + if code < 0xFFFF then + let + newOffset : Int + newOffset = + offset + 6 + in + writeChunks src (mba ++ writeCode code) newOffset otherChunks + + else + let + ( hi, lo ) = + NI.divMod (code - 0x00010000) 0x0400 + + hiCode : String + hiCode = + writeCode (hi + 0xD800) + + lowCode : String + lowCode = + writeCode (lo + 0xDC00) + + newOffset : Int + newOffset = + offset + 12 + in + writeChunks src (mba ++ hiCode ++ lowCode) newOffset otherChunks + + +writeCode : Int -> String +writeCode code = + "\\u" ++ String.padLeft 4 '0' (String.toUpper (Hex.toString code)) diff --git a/src/Compiler/Elm/Version.elm b/src/Compiler/Elm/Version.elm new file mode 100644 index 0000000000..e099b69999 --- /dev/null +++ b/src/Compiler/Elm/Version.elm @@ -0,0 +1,277 @@ +module Compiler.Elm.Version exposing + ( Version(..) + , bumpMajor + , bumpMinor + , bumpPatch + , compare + , compiler + , decoder + , elmCompiler + , encode + , jsonDecoder + , jsonEncoder + , major + , max + , maxVersion + , min + , one + , parser + , toChars + , toComparable + , versionDecoder + , versionEncoder + ) + +import Compiler.Json.Decode as D +import Compiler.Json.Encode as E +import Compiler.Parse.Primitives as P exposing (Col, Row) +import Json.Decode as Decode +import Json.Encode as Encode +import Utils.Bytes.Decode as BD +import Utils.Bytes.Encode as BE + + + +-- VERSION + + +type Version + = Version Int Int Int + + +major : Version -> Int +major (Version major_ _ _) = + major_ + + +compare : Version -> Version -> Order +compare (Version major1 minor1 patch1) (Version major2 minor2 patch2) = + case Basics.compare major1 major2 of + EQ -> + case Basics.compare minor1 minor2 of + EQ -> + Basics.compare patch1 patch2 + + minorRes -> + minorRes + + majorRes -> + majorRes + + +toComparable : Version -> ( Int, Int, Int ) +toComparable (Version major_ minor_ patch_) = + ( major_, minor_, patch_ ) + + +min : Version -> Version -> Version +min v1 v2 = + case compare v1 v2 of + GT -> + v2 + + _ -> + v1 + + +max : Version -> Version -> Version +max v1 v2 = + case compare v1 v2 of + LT -> + v2 + + _ -> + v1 + + +one : Version +one = + Version 1 0 0 + + +maxVersion : Version +maxVersion = + Version 2147483647 0 0 + + +compiler : Version +compiler = + -- case map fromIntegral (Version.versionBranch Paths_elm.version) of + -- major : minor : patch : _ -> + -- Version major minor patch + -- [major, minor] -> + -- Version major minor 0 + -- [major] -> + -- Version major 0 0 + -- [] -> + -- error "could not detect version of elm-compiler you are using" + Version 1 0 0 + + +elmCompiler : Version +elmCompiler = + Version 0 19 1 + + + +-- BUMP + + +bumpPatch : Version -> Version +bumpPatch (Version major_ minor patch) = + Version major_ minor (patch + 1) + + +bumpMinor : Version -> Version +bumpMinor (Version major_ minor _) = + Version major_ (minor + 1) 0 + + +bumpMajor : Version -> Version +bumpMajor (Version major_ _ _) = + Version (major_ + 1) 0 0 + + + +-- TO CHARS + + +toChars : Version -> String +toChars (Version major_ minor patch) = + String.fromInt major_ ++ "." ++ String.fromInt minor ++ "." ++ String.fromInt patch + + + +-- JSON + + +decoder : D.Decoder ( Row, Col ) Version +decoder = + D.customString parser Tuple.pair + + +encode : Version -> E.Value +encode version = + E.string (toChars version) + + + +-- PARSER + + +parser : P.Parser ( Row, Col ) Version +parser = + numberParser + |> P.bind + (\major_ -> + P.word1 '.' Tuple.pair + |> P.bind (\_ -> numberParser) + |> P.bind + (\minor -> + P.word1 '.' Tuple.pair + |> P.bind (\_ -> numberParser) + |> P.fmap + (\patch -> + Version major_ minor patch + ) + ) + ) + + +numberParser : P.Parser ( Row, Col ) Int +numberParser = + P.Parser <| + \(P.State src pos end indent row col) -> + if pos >= end then + P.Eerr row col Tuple.pair + + else + let + word : Char + word = + P.unsafeIndex src pos + in + if word == '0' then + let + newState : P.State + newState = + P.State src (pos + 1) end indent row (col + 1) + in + P.Cok 0 newState + + else if isDigit word then + let + ( total, newPos ) = + chompWord16 src (pos + 1) end (Char.toCode word - 0x30) + + newState : P.State + newState = + P.State src newPos end indent row (col + (newPos - pos)) + in + P.Cok total newState + + else + P.Eerr row col Tuple.pair + + +chompWord16 : String -> Int -> Int -> Int -> ( Int, Int ) +chompWord16 src pos end total = + if pos >= end then + ( total, pos ) + + else + let + word : Char + word = + P.unsafeIndex src pos + in + if isDigit word then + chompWord16 src (pos + 1) end (10 * total + (Char.toCode word - 0x30)) + + else + ( total, pos ) + + +isDigit : Char -> Bool +isDigit word = + '0' <= word && word <= '9' + + + +-- ENCODERS and DECODERS + + +jsonEncoder : Version -> Encode.Value +jsonEncoder version = + Encode.string (toChars version) + + +jsonDecoder : Decode.Decoder Version +jsonDecoder = + Decode.string + |> Decode.andThen + (\str -> + case P.fromByteString parser Tuple.pair str of + Ok version -> + Decode.succeed version + + Err _ -> + Decode.fail "failed to parse version" + ) + + +versionEncoder : Version -> BE.Encoder +versionEncoder (Version major_ minor_ patch_) = + BE.sequence + [ BE.int major_ + , BE.int minor_ + , BE.int patch_ + ] + + +versionDecoder : BD.Decoder Version +versionDecoder = + BD.map3 Version + BD.int + BD.int + BD.int diff --git a/compiler/src/Generate/Html.hs b/src/Compiler/Generate/Html.elm similarity index 50% rename from compiler/src/Generate/Html.hs rename to src/Compiler/Generate/Html.elm index 428eadd5b8..136c1ece0a 100644 --- a/compiler/src/Generate/Html.hs +++ b/src/Compiler/Generate/Html.elm @@ -1,29 +1,23 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -module Generate.Html - ( sandwich - ) - where +module Compiler.Generate.Html exposing + ( leadingLines + , sandwich + ) +import Compiler.Data.Name exposing (Name) -import qualified Data.ByteString.Builder as B -import Data.Monoid ((<>)) -import qualified Data.Name as Name -import Text.RawString.QQ (r) +leadingLines : Int +leadingLines = + 2 --- SANDWICH - - -sandwich :: Name.Name -> B.Builder -> B.Builder +sandwich : Name -> String -> String sandwich moduleName javascript = - let name = Name.toBuilder moduleName in - [r| + """ - |] <> name <> [r| + """ ++ moduleName ++ """ @@ -33,9 +27,9 @@ sandwich moduleName javascript = -|] +""" diff --git a/src/Compiler/Generate/JavaScript.elm b/src/Compiler/Generate/JavaScript.elm new file mode 100644 index 0000000000..80301ae439 --- /dev/null +++ b/src/Compiler/Generate/JavaScript.elm @@ -0,0 +1,740 @@ +module Compiler.Generate.JavaScript exposing + ( Mains + , SourceMaps(..) + , generate + , generateForRepl + , generateForReplEndpoint + ) + +import Basics.Extra exposing (flip) +import Compiler.AST.Canonical as Can +import Compiler.AST.Optimized as Opt +import Compiler.Data.Index as Index +import Compiler.Data.Name as Name +import Compiler.Elm.Kernel as K +import Compiler.Elm.ModuleName as ModuleName +import Compiler.Generate.JavaScript.Builder as JS +import Compiler.Generate.JavaScript.Expression as Expr +import Compiler.Generate.JavaScript.Functions as Functions +import Compiler.Generate.JavaScript.Name as JsName +import Compiler.Generate.JavaScript.SourceMap as SourceMap +import Compiler.Generate.Mode as Mode +import Compiler.Reporting.Annotation as A +import Compiler.Reporting.Doc as D +import Compiler.Reporting.Render.Type as RT +import Compiler.Reporting.Render.Type.Localizer as L +import Data.Map as Dict exposing (Dict) +import Data.Set as EverySet exposing (EverySet) +import Json.Encode as Encode +import Maybe.Extra as Maybe +import System.TypeCheck.IO as IO +import Utils.Crash exposing (crash) +import Utils.Main as Utils + + + +-- GENERATE + + +type alias Graph = + Dict (List String) Opt.Global Opt.Node + + +type alias Mains = + Dict (List String) IO.Canonical Opt.Main + + +type SourceMaps + = NoSourceMaps + | SourceMaps (Dict (List String) IO.Canonical String) + + +firstGeneratedLineNumber : Mode.Mode -> Int +firstGeneratedLineNumber mode = + List.length (String.lines (prelude mode)) + + +prelude : Mode.Mode -> String +prelude mode = + "(function(scope){\n'use strict';" + ++ Functions.functions + ++ perfNote mode + + +generate : SourceMaps -> Int -> Mode.Mode -> Opt.GlobalGraph -> Mains -> String +generate sourceMaps leadingLines mode (Opt.GlobalGraph graph _) mains = + let + state : State + state = + Dict.foldr ModuleName.compareCanonical (addMain mode graph) (emptyState (firstGeneratedLineNumber mode)) mains + in + prelude mode + ++ stateToBuilder state + ++ toMainExports mode mains + ++ escapeNewCode """// EXTRA GUIDA CORE + +function _Utils_TupleN(a, b, ...cs) { + return { $: '#N', a: a, b: b, cs: cs }; +} + +(function(original) { + _Debug_toAnsiString = function(ansi, value) { + if (value.$ === '#N') { + var output = [_Debug_toAnsiString(ansi, value.a), _Debug_toAnsiString(ansi, value.b)]; + for (var k in value.cs) { + output.push(_Debug_toAnsiString(ansi, value.cs[k])); + } + return '(' + output.join(',') + ')'; + } + return original(ansi, value); + } +}(_Debug_toAnsiString))""" + ++ "}(this));" + ++ generateSourceMaps sourceMaps leadingLines state + + +escapeNewCode : String -> String +escapeNewCode code = + "//__START__\n" ++ code ++ "\n//__END__\n" + + +generateSourceMaps : SourceMaps -> Int -> State -> String +generateSourceMaps sourceMaps leadingLines state = + case sourceMaps of + NoSourceMaps -> + "" + + SourceMaps moduleSources -> + let + kernelLeadingLines : Int + kernelLeadingLines = + stateKernels state + |> List.map (String.length << String.filter ((==) '\n')) + |> List.sum + in + SourceMap.generate leadingLines kernelLeadingLines moduleSources (stateToMappings state) + + +addMain : Mode.Mode -> Graph -> IO.Canonical -> Opt.Main -> State -> State +addMain mode graph home _ state = + addGlobal mode graph state (Opt.Global home "main") + + +perfNote : Mode.Mode -> String +perfNote mode = + case mode of + Mode.Prod _ -> + "" + + Mode.Dev Nothing -> + "console.warn('Compiled in DEV mode. Follow the advice at " + ++ D.makeNakedLink "optimize" + ++ " for better performance and smaller assets.');" + + Mode.Dev (Just _) -> + "console.warn('Compiled in DEBUG mode. Follow the advice at " + ++ D.makeNakedLink "optimize" + ++ " for better performance and smaller assets.');" + + +generateForRepl : Bool -> L.Localizer -> Opt.GlobalGraph -> IO.Canonical -> Name.Name -> Can.Annotation -> String +generateForRepl ansi localizer (Opt.GlobalGraph graph _) home name (Can.Forall _ tipe) = + let + mode : Mode.Mode + mode = + Mode.Dev Nothing + + debugState : State + debugState = + addGlobal mode graph (emptyState 0) (Opt.Global ModuleName.debug "toString") + + evalState : State + evalState = + addGlobal mode graph debugState (Opt.Global home name) + in + "process.on('uncaughtException', function(err) { process.stderr.write(err.toString() + '\\n'); process.exit(1); });" + ++ Functions.functions + ++ stateToBuilder evalState + ++ print ansi localizer home name tipe + + +print : Bool -> L.Localizer -> IO.Canonical -> Name.Name -> Can.Type -> String +print ansi localizer home name tipe = + let + value : JsName.Name + value = + JsName.fromGlobal home name + + toString : JsName.Name + toString = + JsName.fromKernel Name.debug "toAnsiString" + + tipeDoc : D.Doc + tipeDoc = + RT.canToDoc localizer RT.None tipe + + bool : String + bool = + if ansi then + "true" + + else + "false" + in + "var _value = " + ++ toString + ++ "(" + ++ bool + ++ ", " + ++ value + ++ ");\nvar _type = " + ++ Encode.encode 0 (Encode.string (D.toString tipeDoc)) + ++ ";\nfunction _print(t) { console.log(_value + (" + ++ bool + ++ " ? '\\x1b[90m' + t + '\\x1b[0m' : t)); }\nif (_value.length + 3 + _type.length >= 80 || _type.indexOf('\\n') >= 0) {\n _print('\\n : ' + _type.split('\\n').join('\\n '));\n} else {\n _print(' : ' + _type);\n}\n" + + + +-- GENERATE FOR REPL ENDPOINT + + +generateForReplEndpoint : L.Localizer -> Opt.GlobalGraph -> IO.Canonical -> Maybe Name.Name -> Can.Annotation -> String +generateForReplEndpoint localizer (Opt.GlobalGraph graph _) home maybeName (Can.Forall _ tipe) = + let + name : Name.Name + name = + Maybe.unwrap Name.replValueToPrint identity maybeName + + mode : Mode.Mode + mode = + Mode.Dev Nothing + + debugState : State + debugState = + addGlobal mode graph (emptyState 0) (Opt.Global ModuleName.debug "toString") + + evalState : State + evalState = + addGlobal mode graph debugState (Opt.Global home name) + in + Functions.functions + ++ stateToBuilder evalState + ++ postMessage localizer home maybeName tipe + + +postMessage : L.Localizer -> IO.Canonical -> Maybe Name.Name -> Can.Type -> String +postMessage localizer home maybeName tipe = + let + name : Name.Name + name = + Maybe.unwrap Name.replValueToPrint identity maybeName + + value : JsName.Name + value = + JsName.fromGlobal home name + + toString : JsName.Name + toString = + JsName.fromKernel Name.debug "toAnsiString" + + tipeDoc : D.Doc + tipeDoc = + RT.canToDoc localizer RT.None tipe + + toName : String -> String + toName n = + "\"" ++ n ++ "\"" + in + "self.postMessage({\n name: " + ++ Maybe.unwrap "null" toName maybeName + ++ ",\n value: " + ++ toString + ++ "(true, " + ++ value + ++ "),\n type: " + ++ D.toString tipeDoc + ++ "\n});\n" + + +type State + = State JS.Builder (EverySet (List String) Opt.Global) + + +emptyState : Int -> State +emptyState startingLine = + State (JS.emptyBuilder startingLine) EverySet.empty + + +stateToBuilder : State -> String +stateToBuilder (State (JS.Builder revKernels code _ _ _) _) = + prependBuilders revKernels code + + +prependBuilders : List String -> String -> String +prependBuilders revBuilders monolith = + List.foldl (\b m -> b ++ m) monolith revBuilders + + +stateToMappings : State -> List JS.Mapping +stateToMappings (State (JS.Builder _ _ _ _ mappings) _) = + mappings + + +stateKernels : State -> List String +stateKernels (State (JS.Builder revKernels _ _ _ _) _) = + revKernels + + +addGlobal : Mode.Mode -> Graph -> State -> Opt.Global -> State +addGlobal mode graph ((State builder seen) as state) global = + if EverySet.member Opt.toComparableGlobal global seen then + state + + else + addGlobalHelp mode graph global <| + State builder (EverySet.insert Opt.toComparableGlobal global seen) + + +addGlobalHelp : Mode.Mode -> Graph -> Opt.Global -> State -> State +addGlobalHelp mode graph ((Opt.Global home _) as global) state = + let + addDeps : EverySet (List String) Opt.Global -> State -> State + addDeps deps someState = + let + sortedDeps : List Opt.Global + sortedDeps = + -- This is required given that it looks like `Data.Set.union` sorts its elements + List.sortWith Opt.compareGlobal (EverySet.toList Opt.compareGlobal deps) + in + List.foldl (flip (addGlobal mode graph)) someState sortedDeps + in + case Utils.find Opt.toComparableGlobal global graph of + Opt.Define expr deps -> + addStmt (addDeps deps state) + (var global (Expr.generate mode home expr)) + + Opt.TrackedDefine region expr deps -> + addStmt (addDeps deps state) + (trackedVar region global (Expr.generate mode home expr)) + + Opt.DefineTailFunc region argNames body deps -> + let + (Opt.Global _ name) = + global + in + addStmt (addDeps deps state) + (trackedVar region global (Expr.generateTailDef mode home name argNames body)) + + Opt.Ctor index arity -> + addStmt state + (var global (Expr.generateCtor mode global index arity)) + + Opt.Link linkedGlobal -> + addGlobal mode graph state linkedGlobal + + Opt.Cycle names values functions deps -> + addStmt (addDeps deps state) + (generateCycle mode global names values functions) + + Opt.Manager effectsType -> + generateManager mode graph global effectsType state + + Opt.Kernel chunks deps -> + if isDebugger global && not (Mode.isDebug mode) then + state + + else + addKernel (addDeps deps state) (generateKernel mode chunks) + + Opt.Enum index -> + addStmt state + (generateEnum mode global index) + + Opt.Box -> + addStmt (addGlobal mode graph state identity_) + (generateBox mode global) + + Opt.PortIncoming decoder deps -> + addStmt (addDeps deps state) + (generatePort mode global "incomingPort" decoder) + + Opt.PortOutgoing encoder deps -> + addStmt (addDeps deps state) + (generatePort mode global "outgoingPort" encoder) + + +addStmt : State -> JS.Stmt -> State +addStmt (State builder seen) stmt = + State (JS.stmtToBuilder stmt builder) seen + + +addKernel : State -> String -> State +addKernel (State builder seen) kernel = + State (JS.addKernel kernel builder) seen + + +var : Opt.Global -> Expr.Code -> JS.Stmt +var (Opt.Global home name) code = + JS.Var (JsName.fromGlobal home name) (Expr.codeToExpr code) + + +trackedVar : A.Region -> Opt.Global -> Expr.Code -> JS.Stmt +trackedVar (A.Region startPos _) (Opt.Global home name) code = + JS.TrackedVar home startPos (JsName.fromGlobalHumanReadable home name) (JsName.fromGlobal home name) (Expr.codeToExpr code) + + +isDebugger : Opt.Global -> Bool +isDebugger (Opt.Global (IO.Canonical _ home) _) = + home == Name.debugger + + + +-- GENERATE CYCLES + + +generateCycle : Mode.Mode -> Opt.Global -> List Name.Name -> List ( Name.Name, Opt.Expr ) -> List Opt.Def -> JS.Stmt +generateCycle mode (Opt.Global ((IO.Canonical _ module_) as home) _) names values functions = + JS.Block + [ JS.Block <| List.map (generateCycleFunc mode home) functions + , JS.Block <| List.map (generateSafeCycle mode home) values + , case List.map (generateRealCycle home) values of + [] -> + JS.EmptyStmt + + (_ :: _) as realBlock -> + case mode of + Mode.Prod _ -> + JS.Block realBlock + + Mode.Dev _ -> + JS.Try (JS.Block realBlock) JsName.dollar <| + JS.Throw <| + JS.ExprString <| + "Some top-level definitions from `" + ++ module_ + ++ "` are causing infinite recursion:\\n" + ++ drawCycle names + ++ "\\n\\nThese errors are very tricky, so read " + ++ D.makeNakedLink "bad-recursion" + ++ " to learn how to fix it!" + ] + + +generateCycleFunc : Mode.Mode -> IO.Canonical -> Opt.Def -> JS.Stmt +generateCycleFunc mode home def = + case def of + Opt.Def _ name expr -> + JS.Var (JsName.fromGlobal home name) (Expr.codeToExpr (Expr.generate mode home expr)) + + Opt.TailDef _ name args expr -> + JS.Var (JsName.fromGlobal home name) (Expr.codeToExpr (Expr.generateTailDef mode home name args expr)) + + +generateSafeCycle : Mode.Mode -> IO.Canonical -> ( Name.Name, Opt.Expr ) -> JS.Stmt +generateSafeCycle mode home ( name, expr ) = + JS.FunctionStmt (JsName.fromCycle home name) [] <| + Expr.codeToStmtList (Expr.generate mode home expr) + + +generateRealCycle : IO.Canonical -> ( Name.Name, expr ) -> JS.Stmt +generateRealCycle home ( name, _ ) = + let + safeName : JsName.Name + safeName = + JsName.fromCycle home name + + realName : JsName.Name + realName = + JsName.fromGlobal home name + in + JS.Block + [ JS.Var realName (JS.ExprCall (JS.ExprRef safeName) []) + , JS.ExprStmt <| + JS.ExprAssign (JS.LRef safeName) <| + JS.ExprFunction Nothing [] [ JS.Return (JS.ExprRef realName) ] + ] + + +drawCycle : List Name.Name -> String +drawCycle names = + let + topLine : String + topLine = + "\\n ┌─────┐" + + nameLine : String -> String + nameLine name = + "\\n │ " ++ name + + midLine : String + midLine = + "\\n │ ↓" + + bottomLine : String + bottomLine = + "\\n └─────┘" + in + String.concat (topLine :: List.intersperse midLine (List.map nameLine names) ++ [ bottomLine ]) + + +generateKernel : Mode.Mode -> List K.Chunk -> String +generateKernel mode chunks = + List.foldr (addChunk mode) "" chunks + + +addChunk : Mode.Mode -> K.Chunk -> String -> String +addChunk mode chunk builder = + case chunk of + K.JS javascript -> + javascript ++ builder + + K.ElmVar home name -> + JsName.fromGlobal home name ++ builder + + K.JsVar home name -> + JsName.fromKernel home name ++ builder + + K.ElmField name -> + Expr.generateField mode name ++ builder + + K.JsField int -> + JsName.fromInt int ++ builder + + K.JsEnum int -> + String.fromInt int ++ builder + + K.Debug -> + case mode of + Mode.Dev _ -> + builder + + Mode.Prod _ -> + "_UNUSED" ++ builder + + K.Prod -> + case mode of + Mode.Dev _ -> + "_UNUSED" ++ builder + + Mode.Prod _ -> + builder + + + +-- GENERATE ENUM + + +generateEnum : Mode.Mode -> Opt.Global -> Index.ZeroBased -> JS.Stmt +generateEnum mode ((Opt.Global home name) as global) index = + JS.Var (JsName.fromGlobal home name) <| + case mode of + Mode.Dev _ -> + Expr.codeToExpr (Expr.generateCtor mode global index 0) + + Mode.Prod _ -> + JS.ExprInt (Index.toMachine index) + + + +-- GENERATE BOX + + +generateBox : Mode.Mode -> Opt.Global -> JS.Stmt +generateBox mode ((Opt.Global home name) as global) = + JS.Var (JsName.fromGlobal home name) <| + case mode of + Mode.Dev _ -> + Expr.codeToExpr (Expr.generateCtor mode global Index.first 1) + + Mode.Prod _ -> + JS.ExprRef (JsName.fromGlobal ModuleName.basics Name.identity_) + + +identity_ : Opt.Global +identity_ = + Opt.Global ModuleName.basics Name.identity_ + + + +-- GENERATE PORTS + + +generatePort : Mode.Mode -> Opt.Global -> Name.Name -> Opt.Expr -> JS.Stmt +generatePort mode (Opt.Global home name) makePort converter = + JS.Var (JsName.fromGlobal home name) <| + JS.ExprCall (JS.ExprRef (JsName.fromKernel Name.platform makePort)) + [ JS.ExprString name + , Expr.codeToExpr (Expr.generate mode home converter) + ] + + + +-- GENERATE MANAGER + + +generateManager : Mode.Mode -> Graph -> Opt.Global -> Opt.EffectsType -> State -> State +generateManager mode graph (Opt.Global ((IO.Canonical _ moduleName) as home) _) effectsType state = + let + managerLVar : JS.LValue + managerLVar = + JS.LBracket + (JS.ExprRef (JsName.fromKernel Name.platform "effectManagers")) + (JS.ExprString moduleName) + + ( deps, args, stmts ) = + generateManagerHelp home effectsType + + createManager : JS.Stmt + createManager = + JS.ExprStmt <| + JS.ExprAssign managerLVar <| + JS.ExprCall (JS.ExprRef (JsName.fromKernel Name.platform "createManager")) args + in + addStmt (List.foldl (flip (addGlobal mode graph)) state deps) <| + JS.Block (createManager :: stmts) + + +generateLeaf : IO.Canonical -> Name.Name -> JS.Stmt +generateLeaf ((IO.Canonical _ moduleName) as home) name = + JS.Var (JsName.fromGlobal home name) <| + JS.ExprCall leaf [ JS.ExprString moduleName ] + + +leaf : JS.Expr +leaf = + JS.ExprRef (JsName.fromKernel Name.platform "leaf") + + +generateManagerHelp : IO.Canonical -> Opt.EffectsType -> ( List Opt.Global, List JS.Expr, List JS.Stmt ) +generateManagerHelp home effectsType = + let + dep : Name.Name -> Opt.Global + dep name = + Opt.Global home name + + ref : Name.Name -> JS.Expr + ref name = + JS.ExprRef (JsName.fromGlobal home name) + in + case effectsType of + Opt.Cmd -> + ( [ dep "init", dep "onEffects", dep "onSelfMsg", dep "cmdMap" ] + , [ ref "init", ref "onEffects", ref "onSelfMsg", ref "cmdMap" ] + , [ generateLeaf home "command" ] + ) + + Opt.Sub -> + ( [ dep "init", dep "onEffects", dep "onSelfMsg", dep "subMap" ] + , [ ref "init", ref "onEffects", ref "onSelfMsg", JS.ExprInt 0, ref "subMap" ] + , [ generateLeaf home "subscription" ] + ) + + Opt.Fx -> + ( [ dep "init", dep "onEffects", dep "onSelfMsg", dep "cmdMap", dep "subMap" ] + , [ ref "init", ref "onEffects", ref "onSelfMsg", ref "cmdMap", ref "subMap" ] + , [ generateLeaf home "command" + , generateLeaf home "subscription" + ] + ) + + + +-- MAIN EXPORTS + + +toMainExports : Mode.Mode -> Mains -> String +toMainExports mode mains = + let + export : JsName.Name + export = + JsName.fromKernel Name.platform "export" + + exports : String + exports = + generateExports mode (Dict.foldr ModuleName.compareCanonical addToTrie emptyTrie mains) + in + export ++ "(" ++ exports ++ ");" + + +generateExports : Mode.Mode -> Trie -> String +generateExports mode (Trie maybeMain subs) = + let + starter : String -> String + starter end = + case maybeMain of + Nothing -> + "{" + + Just ( home, main ) -> + let + (JS.Builder _ code _ _ _) = + JS.exprToBuilder (Expr.generateMain mode home main) (JS.emptyBuilder 0) + in + "{'init':" + ++ code + ++ end + in + case Dict.toList compare subs of + [] -> + starter "" ++ "}" + + ( name, subTrie ) :: otherSubTries -> + starter "," + ++ "'" + ++ name + ++ "':" + ++ generateExports mode subTrie + ++ List.foldl (flip (addSubTrie mode)) "}" otherSubTries + + +addSubTrie : Mode.Mode -> String -> ( Name.Name, Trie ) -> String +addSubTrie mode end ( name, trie ) = + ",'" ++ name ++ "':" ++ generateExports mode trie ++ end + + + +-- BUILD TRIES + + +type Trie + = Trie (Maybe ( IO.Canonical, Opt.Main )) (Dict String Name.Name Trie) + + +emptyTrie : Trie +emptyTrie = + Trie Nothing Dict.empty + + +addToTrie : IO.Canonical -> Opt.Main -> Trie -> Trie +addToTrie ((IO.Canonical _ moduleName) as home) main trie = + merge trie <| segmentsToTrie home (Name.splitDots moduleName) main + + +segmentsToTrie : IO.Canonical -> List Name.Name -> Opt.Main -> Trie +segmentsToTrie home segments main = + case segments of + [] -> + Trie (Just ( home, main )) Dict.empty + + segment :: otherSegments -> + Trie Nothing (Dict.singleton identity segment (segmentsToTrie home otherSegments main)) + + +merge : Trie -> Trie -> Trie +merge (Trie main1 subs1) (Trie main2 subs2) = + Trie + (checkedMerge main1 main2) + (Utils.mapUnionWith identity compare merge subs1 subs2) + + +checkedMerge : Maybe a -> Maybe a -> Maybe a +checkedMerge a b = + case ( a, b ) of + ( Nothing, main ) -> + main + + ( main, Nothing ) -> + main + + ( Just _, Just _ ) -> + crash "cannot have two modules with the same name" diff --git a/src/Compiler/Generate/JavaScript/Builder.elm b/src/Compiler/Generate/JavaScript/Builder.elm new file mode 100644 index 0000000000..a06fe84d14 --- /dev/null +++ b/src/Compiler/Generate/JavaScript/Builder.elm @@ -0,0 +1,1110 @@ +module Compiler.Generate.JavaScript.Builder exposing + ( Builder(..) + , Case(..) + , Expr(..) + , InfixOp(..) + , LValue(..) + , Mapping(..) + , PrefixOp(..) + , Stmt(..) + , addByteString + , addKernel + , emptyBuilder + , exprToBuilder + , stmtToBuilder + ) + +-- Based on the language-ecmascript package. +-- https://hackage.haskell.org/package/language-ecmascript +-- They did the hard work of reading the spec to figure out +-- how all the types should fit together. + +import Compiler.Generate.JavaScript.Name as Name +import Compiler.Json.Encode as Json +import Compiler.Reporting.Annotation as A +import Maybe.Extra as Maybe +import System.TypeCheck.IO as IO + + + +-- EXPRESSIONS +-- NOTE: I tried making this create a B.Builder directly. +-- +-- The hope was that it'd allocate less and speed things up, but it seemed +-- to be neutral for perf. +-- +-- The downside is that Generate.JavaScript.Expression inspects the +-- structure of Expr and Stmt on some occassions to try to strip out +-- unnecessary closures. I think these closures are already avoided +-- by other logic in code gen these days, but I am not 100% certain. +-- +-- For this to be worth it, I think it would be necessary to avoid +-- returning tuples when generating expressions. +-- + + +type Expr + = ExprString String + | ExprTrackedString IO.Canonical A.Position String + | ExprFloat String + | ExprTrackedFloat IO.Canonical A.Position String + | ExprInt Int + | ExprTrackedInt IO.Canonical A.Position Int + | ExprBool Bool + | ExprTrackedBool IO.Canonical A.Position Bool + | ExprJson Json.Value + | ExprArray (List Expr) + | ExprTrackedArray IO.Canonical A.Region (List Expr) + | ExprObject (List ( Name.Name, Expr )) + | ExprTrackedObject IO.Canonical A.Region (List ( A.Located Name.Name, Expr )) + | ExprRef Name.Name + | ExprTrackedRef IO.Canonical A.Position Name.Name Name.Name + | ExprAccess Expr Name.Name + | ExprTrackedAccess Expr IO.Canonical A.Position Name.Name + | ExprIndex Expr Expr + | ExprPrefix PrefixOp Expr + | ExprInfix InfixOp Expr Expr + | ExprIf Expr Expr Expr + | ExprAssign LValue Expr + | ExprCall Expr (List Expr) + | ExprTrackedNormalCall IO.Canonical A.Position Expr Expr (List Expr) + | ExprFunction (Maybe Name.Name) (List Name.Name) (List Stmt) + | ExprTrackedFunction IO.Canonical (List (A.Located Name.Name)) (List Stmt) + + +type LValue + = LRef Name.Name + | LBracket Expr Expr + + + +-- STATEMENTS + + +type Stmt + = Block (List Stmt) + | EmptyStmt + | ExprStmt Expr + | IfStmt Expr Stmt Stmt + | Switch Expr (List Case) + | While Expr Stmt + | Break (Maybe Name.Name) + | Continue (Maybe Name.Name) + | Labelled Name.Name Stmt + | Try Stmt Name.Name Stmt + | Throw Expr + | Return Expr + | Var Name.Name Expr + | TrackedVar IO.Canonical A.Position Name.Name Name.Name Expr + | Vars (List ( Name.Name, Expr )) + | FunctionStmt Name.Name (List Name.Name) (List Stmt) + + +type Case + = Case Expr (List Stmt) + | Default (List Stmt) + + + +-- OPERATORS + + +type InfixOp + = OpAdd + | OpSub + | OpMul + | OpDiv + | OpMod + | OpEq + | OpNe + | OpLt + | OpLe + | OpGt + | OpGe + | OpAnd + | OpOr + | OpBitwiseAnd + | OpBitwiseXor + | OpBitwiseOr + | OpLShift + | OpSpRShift + | OpZfRShift + + +type PrefixOp + = PrefixNot + | PrefixNegate + | PrefixComplement + + + +-- ENCODE + + +stmtToBuilder : Stmt -> Builder -> Builder +stmtToBuilder stmts builder = + fromStmt levelZero stmts builder + + +exprToBuilder : Expr -> Builder -> Builder +exprToBuilder expr builder = + fromExpr levelZero Whatever expr builder + + + +-- INDENT LEVEL + + +type Level + = Level String (() -> Level) + + +levelZero : Level +levelZero = + Level "" (\_ -> makeLevel 1 (String.repeat 16 "\t")) + + +makeLevel : Int -> String -> Level +makeLevel level oldTabs = + let + tabs : String + tabs = + if level <= String.length oldTabs then + oldTabs + + else + oldTabs ++ oldTabs + in + Level (String.left level tabs) (\_ -> makeLevel (level + 1) tabs) + + + +-- HELPERS + + +commaSep : (a -> Builder -> Builder) -> List a -> Builder -> Builder +commaSep fn exprs builder = + case exprs of + [] -> + builder + + [ first ] -> + fn first builder + + first :: rest -> + commaSep fn rest (addAscii ", " (fn first builder)) + + +commaNewlineSep : Level -> (a -> Builder -> Builder) -> List a -> Builder -> Builder +commaNewlineSep ((Level _ nextLevel) as level) fn exprs builder = + case exprs of + [] -> + builder + + [ first ] -> + fn first builder + + first :: rest -> + let + (Level deeperIndent _) = + nextLevel () + in + commaNewlineSep level fn rest (addByteString deeperIndent (addLine (addAscii "," (fn first builder)))) + + + +-- STATEMENTS + + +fromStmtBlock : Level -> List Stmt -> Builder -> Builder +fromStmtBlock level stmts builder = + List.foldl (fromStmt level) builder stmts + + +fromStmt : Level -> Stmt -> Builder -> Builder +fromStmt ((Level indent nextLevel) as level) statement builder = + case statement of + Block stmts -> + fromStmtBlock level stmts builder + + EmptyStmt -> + builder + + ExprStmt expr -> + builder + |> addByteString indent + |> fromExpr level Whatever expr + |> addAscii ";" + |> addLine + + IfStmt condition thenStmt elseStmt -> + builder + |> addByteString indent + |> addAscii "if (" + |> fromExpr level Whatever condition + |> addAscii ") {" + |> addLine + |> fromStmt (nextLevel ()) thenStmt + |> addByteString indent + |> addAscii "} else {" + |> addLine + |> fromStmt (nextLevel ()) elseStmt + |> addByteString indent + |> addAscii "}" + |> addLine + + Switch expr clauses -> + builder + |> addByteString indent + |> addAscii "switch (" + |> fromExpr level Whatever expr + |> addAscii ") {" + |> addLine + |> fromClauses (nextLevel ()) clauses + |> addByteString indent + |> addAscii "}" + |> addLine + + While expr stmt -> + builder + |> addByteString indent + |> addAscii "while (" + |> fromExpr level Whatever expr + |> addAscii ") {" + |> addLine + |> fromStmt (nextLevel ()) stmt + |> addByteString indent + |> addAscii "}" + |> addLine + + Break Nothing -> + builder + |> addAscii "break;" + |> addLine + + Break (Just label) -> + builder + |> addByteString indent + |> addAscii "break " + |> addByteString label + |> addAscii ";" + |> addLine + + Continue Nothing -> + builder + |> addAscii "continue;" + |> addLine + + Continue (Just label) -> + builder + |> addByteString indent + |> addAscii "continue " + |> addByteString label + |> addAscii ";" + |> addLine + + Labelled label stmt -> + builder + |> addByteString indent + |> addByteString label + |> addAscii ":" + |> addLine + |> fromStmt level stmt + + Try tryStmt errorName catchStmt -> + builder + |> addByteString indent + |> addAscii "try {" + |> addLine + |> fromStmt (nextLevel ()) tryStmt + |> addByteString indent + |> addAscii "} catch (" + |> addByteString errorName + |> addAscii ") {" + |> addLine + |> fromStmt (nextLevel ()) catchStmt + |> addByteString indent + |> addAscii "}" + |> addLine + + Throw expr -> + builder + |> addByteString indent + |> addAscii "throw " + |> fromExpr level Whatever expr + |> addAscii ";" + + Return expr -> + builder + |> addByteString indent + |> addAscii "return " + |> fromExpr level Whatever expr + |> addAscii ";" + |> addLine + + Var name expr -> + builder + |> addByteString indent + |> addAscii "var " + |> addByteString name + |> addAscii " = " + |> fromExpr level Whatever expr + |> addAscii ";" + |> addLine + + TrackedVar moduleName pos name genName expr -> + builder + |> addByteString indent + |> addAscii "var " + |> addName moduleName pos name genName + |> addAscii " = " + |> fromExpr level Whatever expr + |> addAscii ";" + |> addLine + + Vars [] -> + builder + + Vars vars -> + builder + |> addByteString indent + |> addAscii "var " + |> commaNewlineSep level (varToBuilder level) vars + |> addAscii ";" + |> addLine + + FunctionStmt name args stmts -> + builder + |> addByteString indent + |> addAscii "function " + |> addByteString name + |> addAscii "(" + |> commaSep addByteString args + |> addAscii ") {" + |> addLine + |> fromStmtBlock (nextLevel ()) stmts + |> addByteString indent + |> addAscii "}" + |> addLine + + + +-- SWITCH CLAUSES + + +fromClause : Level -> Case -> Builder -> Builder +fromClause ((Level indent nextLevel) as level) clause builder = + case clause of + Case expr stmts -> + builder + |> addByteString indent + |> addAscii "case " + |> fromExpr level Whatever expr + |> addAscii ":" + |> addLine + |> fromStmtBlock (nextLevel ()) stmts + + Default stmts -> + builder + |> addByteString indent + |> addAscii "default:" + |> addLine + |> fromStmtBlock (nextLevel ()) stmts + + +fromClauses : Level -> List Case -> Builder -> Builder +fromClauses level clauses builder = + case clauses of + [] -> + builder + + first :: rest -> + fromClauses level rest (fromClause level first builder) + + + +-- VAR DECLS + + +varToBuilder : Level -> ( Name.Name, Expr ) -> Builder -> Builder +varToBuilder level ( name, expr ) builder = + builder + |> addByteString name + |> addAscii " = " + |> fromExpr level Whatever expr + + + +-- EXPRESSIONS + + +type Lines + = One + | Many + + +merge : Lines -> Lines -> Lines +merge a b = + if a == Many || b == Many then + Many + + else + One + + +linesMap : (a -> Lines) -> List a -> Bool +linesMap func xs = + linesMapHelp func xs + + +linesMapHelp : (a -> Lines) -> List a -> Bool +linesMapHelp func xs = + case xs of + [] -> + False + + a :: rest -> + case func a of + Many -> + True + + One -> + linesMapHelp func rest + + +type Grouping + = Atomic + | Whatever + + +parensFor : Grouping -> Builder -> (Builder -> Builder) -> Builder +parensFor grouping builder fillContent = + case grouping of + Atomic -> + builder + |> addAscii "(" + |> fillContent + |> addAscii ")" + + Whatever -> + fillContent builder + + +fromExpr : Level -> Grouping -> Expr -> Builder -> Builder +fromExpr ((Level indent nextLevel) as level) grouping expression builder = + let + (Level deeperIndent _) = + nextLevel () + in + case expression of + ExprString string -> + addByteString ("'" ++ string ++ "'") builder + + ExprTrackedString moduleName position string -> + addTrackedByteString moduleName position ("'" ++ string ++ "'") builder + + ExprFloat float -> + addByteString float builder + + ExprTrackedFloat moduleName position float -> + addTrackedByteString moduleName position float builder + + ExprInt n -> + addByteString (String.fromInt n) builder + + ExprTrackedInt moduleName position n -> + addTrackedByteString moduleName position (String.fromInt n) builder + + ExprBool bool -> + addAscii + (if bool then + "true" + + else + "false" + ) + builder + + ExprTrackedBool moduleName position bool -> + addTrackedByteString moduleName + position + (if bool then + "true" + + else + "false" + ) + builder + + ExprJson json -> + addAscii (Json.encodeUgly json) builder + + ExprArray exprs -> + let + anyMany : Bool + anyMany = + linesMap (fromExprLines level) exprs + in + if anyMany then + builder + |> addAscii "[" + |> addLine + |> addByteString deeperIndent + |> commaNewlineSep level (fromExpr level Whatever) exprs + |> addLine + |> addByteString indent + |> addAscii "]" + + else + builder + |> addAscii "[" + |> commaSep (fromExpr level Whatever) exprs + |> addAscii "]" + + ExprTrackedArray moduleName (A.Region start (A.Position endLine endCol)) exprs -> + let + anyMany : Bool + anyMany = + linesMap (fromExprLines level) exprs + in + if anyMany then + builder + |> addTrackedByteString moduleName start "[" + |> addLine + |> addByteString deeperIndent + |> commaNewlineSep level (fromExpr level Whatever) exprs + |> addLine + |> addByteString indent + |> addTrackedByteString moduleName (A.Position endLine (endCol - 1)) "]" + + else + builder + |> addTrackedByteString moduleName start "[" + |> commaSep (fromExpr level Whatever) exprs + |> addTrackedByteString moduleName (A.Position endLine (endCol - 1)) "]" + + ExprObject fields -> + let + anyMany : Bool + anyMany = + linesMap (fromFieldLines (nextLevel ())) fields + in + if anyMany then + builder + |> addAscii "{" + |> addLine + |> addByteString deeperIndent + |> commaNewlineSep level (fromField (nextLevel ())) fields + |> addLine + |> addByteString indent + |> addAscii "}" + + else + builder + |> addAscii "{" + |> commaSep (fromField (nextLevel ())) fields + |> addAscii "}" + + ExprTrackedObject moduleName (A.Region start (A.Position endLine endCol)) fields -> + let + anyMany : Bool + anyMany = + linesMap (trackedFromFieldLines (nextLevel ())) fields + in + if anyMany then + builder + |> addTrackedByteString moduleName start "{" + |> addLine + |> addByteString deeperIndent + |> commaNewlineSep level (trackedFromField (nextLevel ()) moduleName) fields + |> addLine + |> addByteString indent + |> addTrackedByteString moduleName (A.Position endLine (endCol - 1)) "}" + + else + builder + |> addTrackedByteString moduleName start "{" + |> commaSep (trackedFromField (nextLevel ()) moduleName) fields + |> addTrackedByteString moduleName (A.Position endLine (endCol - 1)) "}" + + ExprRef name -> + addByteString name builder + + ExprTrackedRef position moduleName name generatedName -> + addName position moduleName name generatedName builder + + ExprAccess expr field -> + makeDot level expr field builder + + ExprTrackedAccess expr moduleName ((A.Position fieldLine fieldCol) as position) field -> + builder + |> fromExpr level Atomic expr + |> addTrackedDot moduleName (A.Position fieldLine (fieldCol - 1)) + |> addName moduleName position field field + + ExprIndex expr bracketedExpr -> + makeBracketed level expr bracketedExpr builder + + ExprPrefix op expr -> + parensFor grouping builder <| + (fromPrefix op + >> fromExpr level Atomic expr + ) + + ExprInfix op leftExpr rightExpr -> + parensFor grouping builder <| + \b -> + fromExpr level Atomic leftExpr b + |> fromInfix op + |> fromExpr level Atomic rightExpr + + ExprIf condExpr thenExpr elseExpr -> + parensFor grouping builder <| + fromExpr level Atomic condExpr + >> addAscii " ? " + >> fromExpr level Atomic thenExpr + >> addAscii " : " + >> fromExpr level Atomic elseExpr + + ExprAssign lValue expr -> + parensFor grouping builder <| + \b -> + fromLValue level lValue b + |> addAscii " = " + |> fromExpr level Whatever expr + + ExprCall function args -> + let + anyMany : Bool + anyMany = + linesMap (fromExprLines (nextLevel ())) args + + funcB : Builder + funcB = + fromExpr level Atomic function builder + in + if anyMany then + funcB + |> addAscii "(" + |> addLine + |> addByteString deeperIndent + |> commaNewlineSep level (fromExpr (nextLevel ()) Whatever) args + |> addAscii ")" + + else + funcB + |> addAscii "(" + |> commaSep (fromExpr (nextLevel ()) Whatever) args + |> addAscii ")" + + ExprTrackedNormalCall moduleName position helper function args -> + let + anyMany : Bool + anyMany = + linesMap (fromExprLines (nextLevel ())) args + + trackedHelper : Expr + trackedHelper = + case ( trackedNameFromExpr function, helper ) of + ( Just functionName, ExprRef helperName ) -> + ExprTrackedRef moduleName position functionName helperName + + _ -> + helper + + funcB : Builder + funcB = + fromExpr level Atomic trackedHelper builder + in + if anyMany then + funcB + |> addAscii "(" + |> addLine + |> addByteString deeperIndent + |> commaNewlineSep level (fromExpr (nextLevel ()) Whatever) (function :: args) + |> addAscii ")" + + else + funcB + |> addAscii "(" + |> commaSep (fromExpr (nextLevel ()) Whatever) (function :: args) + |> addAscii ")" + + ExprFunction maybeName args stmts -> + builder + |> addAscii "function " + |> addByteString (Maybe.unwrap "" identity maybeName) + |> addAscii "(" + |> commaSep addByteString args + |> addAscii ") {" + |> addLine + |> fromStmtBlock (nextLevel ()) stmts + |> addByteString indent + |> addAscii "}" + + ExprTrackedFunction moduleName args stmts -> + builder + |> addAscii "function " + |> addAscii "(" + |> commaSep (\(A.At (A.Region start _) name) -> addName moduleName start name name) args + |> addAscii ") {" + |> addLine + |> fromStmtBlock (nextLevel ()) stmts + |> addByteString indent + |> addAscii "}" + + +trackedNameFromExpr : Expr -> Maybe Name.Name +trackedNameFromExpr expr = + case expr of + ExprTrackedRef _ _ name _ -> + Just name + + _ -> + Nothing + + +fromExprLines : Level -> Expr -> Lines +fromExprLines level expression = + case expression of + ExprString _ -> + One + + ExprTrackedString _ _ _ -> + One + + ExprFloat _ -> + One + + ExprTrackedFloat _ _ _ -> + One + + ExprInt _ -> + One + + ExprTrackedInt _ _ _ -> + One + + ExprBool _ -> + One + + ExprTrackedBool _ _ _ -> + One + + ExprJson _ -> + One + + ExprArray _ -> + Many + + ExprTrackedArray _ _ _ -> + Many + + ExprObject _ -> + Many + + ExprTrackedObject _ _ _ -> + Many + + ExprRef _ -> + One + + ExprTrackedRef _ _ _ _ -> + One + + ExprAccess expr _ -> + makeDotLines level expr + + ExprTrackedAccess expr _ _ _ -> + fromExprLines level expr + + ExprIndex expr bracketedExpr -> + makeBracketedLines level expr bracketedExpr + + ExprPrefix _ expr -> + fromExprLines level expr + + ExprInfix _ leftExpr rightExpr -> + merge (fromExprLines level leftExpr) (fromExprLines level rightExpr) + + ExprIf _ _ _ -> + Many + + ExprAssign lValue expr -> + merge (fromLValueLines level lValue) (fromExprLines level expr) + + ExprCall _ _ -> + Many + + ExprTrackedNormalCall _ _ _ _ _ -> + Many + + ExprFunction _ _ _ -> + Many + + ExprTrackedFunction _ _ _ -> + Many + + + +-- FIELDS + + +fromField : Level -> ( Name.Name, Expr ) -> Builder -> Builder +fromField level ( field, expr ) builder = + builder + |> addByteString field + |> addAscii ": " + |> fromExpr level Whatever expr + + +fromFieldLines : Level -> ( Name.Name, Expr ) -> Lines +fromFieldLines level ( _, expr ) = + fromExprLines level expr + + +trackedFromField : Level -> IO.Canonical -> ( A.Located Name.Name, Expr ) -> Builder -> Builder +trackedFromField level moduleName ( A.At (A.Region start end) field, expr ) builder = + builder + |> addName moduleName start field field + |> addTrackedByteString moduleName end ": " + |> fromExpr level Whatever expr + + +trackedFromFieldLines : Level -> ( A.Located Name.Name, Expr ) -> Lines +trackedFromFieldLines level ( _, expr ) = + fromExprLines level expr + + + +-- VALUES + + +fromLValue : Level -> LValue -> Builder -> Builder +fromLValue level lValue builder = + case lValue of + LRef name -> + addByteString name builder + + LBracket expr bracketedExpr -> + makeBracketed level expr bracketedExpr builder + + +fromLValueLines : Level -> LValue -> Lines +fromLValueLines level lValue = + case lValue of + LRef _ -> + One + + LBracket expr bracketedExpr -> + makeBracketedLines level expr bracketedExpr + + +makeDot : Level -> Expr -> Name.Name -> Builder -> Builder +makeDot level expr field builder = + builder + |> fromExpr level Atomic expr + |> addAscii "." + |> addByteString field + + +makeDotLines : Level -> Expr -> Lines +makeDotLines level expr = + fromExprLines level expr + + +makeBracketed : Level -> Expr -> Expr -> Builder -> Builder +makeBracketed level expr bracketedExpr builder = + fromExpr level Atomic expr builder + |> addAscii "[" + |> fromExpr level Whatever bracketedExpr + |> addAscii "]" + + +makeBracketedLines : Level -> Expr -> Expr -> Lines +makeBracketedLines level expr bracketedExpr = + merge (fromExprLines level expr) (fromExprLines level bracketedExpr) + + + +-- OPERATORS + + +fromPrefix : PrefixOp -> Builder -> Builder +fromPrefix op = + addAscii + (case op of + PrefixNot -> + "!" + + PrefixNegate -> + "-" + + PrefixComplement -> + "~" + ) + + +fromInfix : InfixOp -> Builder -> Builder +fromInfix op = + addAscii + (case op of + OpAdd -> + " + " + + OpSub -> + " - " + + OpMul -> + " * " + + OpDiv -> + " / " + + OpMod -> + " % " + + OpEq -> + " === " + + OpNe -> + " !== " + + OpLt -> + " < " + + OpLe -> + " <= " + + OpGt -> + " > " + + OpGe -> + " >= " + + OpAnd -> + " && " + + OpOr -> + " || " + + OpBitwiseAnd -> + " & " + + OpBitwiseXor -> + " ^ " + + OpBitwiseOr -> + " | " + + OpLShift -> + " << " + + OpSpRShift -> + " >> " + + OpZfRShift -> + " >>> " + ) + + + +-- BUILDER + + +type Builder + = Builder (List String) String Int Int (List Mapping) + + +type Mapping + = Mapping Int Int IO.Canonical (Maybe Name.Name) Int Int + + +emptyBuilder : Int -> Builder +emptyBuilder currentLine = + Builder [] "" currentLine 1 [] + + +addAscii : String -> Builder -> Builder +addAscii ascii (Builder revKernels revBuilders currentLine currentCol mappings) = + Builder revKernels (revBuilders ++ ascii) currentLine (currentCol + String.length ascii) mappings + + +addKernel : String -> Builder -> Builder +addKernel kernel (Builder revKernels revBuilders currentLine currentCol mappings) = + Builder (kernel :: revKernels) revBuilders currentLine currentCol mappings + + +addByteString : String -> Builder -> Builder +addByteString str (Builder revKernels revBuilders currentLine currentCol mappings) = + let + bsLines : Int + bsLines = + List.length (String.lines str) - 1 + in + if bsLines == 0 then + let + bsSize : Int + bsSize = + String.length str + in + Builder revKernels (revBuilders ++ str) currentLine (currentCol + bsSize) mappings + + else + Builder revKernels (revBuilders ++ str) (currentLine + bsLines) 1 mappings + + +addTrackedByteString : IO.Canonical -> A.Position -> String -> Builder -> Builder +addTrackedByteString moduleName (A.Position line col) str (Builder revKernels revBuilders currentLine currentCol mappings) = + let + bsLines : Int + bsLines = + List.length (String.lines str) - 1 + + newMappings : List Mapping + newMappings = + Mapping line col moduleName Nothing currentLine currentCol + :: mappings + in + if bsLines == 0 then + let + bsSize : Int + bsSize = + String.length str + in + Builder revKernels (revBuilders ++ str) currentLine (currentCol + bsSize) newMappings + + else + Builder revKernels (revBuilders ++ str) (currentLine + bsLines) 1 newMappings + + +addName : IO.Canonical -> A.Position -> Name.Name -> Name.Name -> Builder -> Builder +addName moduleName (A.Position line col) name genName (Builder revKernels revBuilders currentLine currentCol mappings) = + let + size : Int + size = + String.length genName + in + Builder revKernels + (revBuilders ++ genName) + currentLine + (currentCol + size) + (Mapping line col moduleName (Just name) currentLine currentCol + :: mappings + ) + + +addTrackedDot : IO.Canonical -> A.Position -> Builder -> Builder +addTrackedDot moduleName (A.Position line col) (Builder revKernels revBuilders currentLine currentCol mappings) = + Builder revKernels + (revBuilders ++ ".") + currentLine + (currentCol + 1) + (Mapping line col moduleName Nothing currentLine currentCol + :: mappings + ) + + +addLine : Builder -> Builder +addLine (Builder revKernels revBuilders currentLine _ mappings) = + Builder revKernels (revBuilders ++ "\n") (currentLine + 1) 1 mappings diff --git a/src/Compiler/Generate/JavaScript/Expression.elm b/src/Compiler/Generate/JavaScript/Expression.elm new file mode 100644 index 0000000000..b3c9dee291 --- /dev/null +++ b/src/Compiler/Generate/JavaScript/Expression.elm @@ -0,0 +1,1453 @@ +module Compiler.Generate.JavaScript.Expression exposing + ( Code + , codeToExpr + , codeToStmtList + , generate + , generateCtor + , generateField + , generateMain + , generateTailDef + ) + +import Compiler.AST.Canonical as Can +import Compiler.AST.Optimized as Opt +import Compiler.AST.Utils.Shader as Shader +import Compiler.Data.Index as Index +import Compiler.Data.Name as Name +import Compiler.Elm.Compiler.Type as Type +import Compiler.Elm.Compiler.Type.Extract as Extract +import Compiler.Elm.ModuleName as ModuleName +import Compiler.Elm.Package as Pkg +import Compiler.Elm.Version as V +import Compiler.Generate.JavaScript.Builder as JS +import Compiler.Generate.JavaScript.Name as JsName +import Compiler.Generate.Mode as Mode +import Compiler.Json.Encode as Encode +import Compiler.Optimize.DecisionTree as DT +import Compiler.Reporting.Annotation as A +import Data.Map as Dict exposing (Dict) +import Data.Set as EverySet +import Prelude +import System.TypeCheck.IO as IO +import Utils.Crash exposing (crash) +import Utils.Main as Utils + + +generateJsExpr : Mode.Mode -> IO.Canonical -> Opt.Expr -> JS.Expr +generateJsExpr mode parentModule expression = + codeToExpr (generate mode parentModule expression) + + +generate : Mode.Mode -> IO.Canonical -> Opt.Expr -> Code +generate mode parentModule expression = + case expression of + Opt.Bool (A.Region start _) bool -> + JsExpr <| JS.ExprTrackedBool parentModule start bool + + Opt.Chr (A.Region start _) char -> + JsExpr <| + case mode of + Mode.Dev _ -> + JS.ExprCall toChar [ JS.ExprTrackedString parentModule start char ] + + Mode.Prod _ -> + JS.ExprTrackedString parentModule start char + + Opt.Str (A.Region start _) string -> + JsExpr <| JS.ExprTrackedString parentModule start string + + Opt.Int (A.Region start _) int -> + JsExpr <| JS.ExprTrackedInt parentModule start int + + Opt.Float (A.Region start _) float -> + JsExpr <| + JS.ExprTrackedFloat parentModule start <| + if float == toFloat (floor float) then + String.fromFloat float ++ ".0" + + else + String.fromFloat float + + Opt.VarLocal name -> + JsExpr <| JS.ExprRef (JsName.fromLocal name) + + Opt.TrackedVarLocal (A.Region startPos _) name -> + JsExpr <| JS.ExprTrackedRef parentModule startPos (JsName.fromLocalHumanReadable name) (JsName.fromLocal name) + + Opt.VarGlobal (A.Region startPos _) (Opt.Global home name) -> + JsExpr <| JS.ExprTrackedRef parentModule startPos (JsName.fromGlobalHumanReadable home name) (JsName.fromGlobal home name) + + Opt.VarEnum (A.Region startPos _) (Opt.Global home name) index -> + case mode of + Mode.Dev _ -> + JsExpr <| JS.ExprTrackedRef parentModule startPos (JsName.fromGlobalHumanReadable home name) (JsName.fromGlobal home name) + + Mode.Prod _ -> + JsExpr <| JS.ExprInt (Index.toMachine index) + + Opt.VarBox (A.Region startPos _) (Opt.Global home name) -> + JsExpr <| + case mode of + Mode.Dev _ -> + JS.ExprTrackedRef parentModule startPos (JsName.fromGlobalHumanReadable home name) (JsName.fromGlobal home name) + + Mode.Prod _ -> + JS.ExprRef (JsName.fromGlobal ModuleName.basics Name.identity_) + + Opt.VarCycle (A.Region startPos _) home name -> + JsExpr <| JS.ExprCall (JS.ExprTrackedRef parentModule startPos (JsName.fromGlobalHumanReadable home name) (JsName.fromCycle home name)) [] + + Opt.VarDebug region name home unhandledValueName -> + JsExpr <| generateDebug name home region unhandledValueName + + Opt.VarKernel (A.Region startPos _) home name -> + JsExpr <| JS.ExprTrackedRef parentModule startPos (JsName.fromKernel home name) (JsName.fromKernel home name) + + Opt.List region entries -> + case entries of + [] -> + JsExpr <| JS.ExprRef (JsName.fromKernel Name.list "Nil") + + _ -> + JsExpr <| + JS.ExprCall (JS.ExprRef (JsName.fromKernel Name.list "fromArray")) + [ JS.ExprTrackedArray parentModule region <| List.map (generateJsExpr mode parentModule) entries + ] + + Opt.Function args body -> + generateFunction (List.map JsName.fromLocal args) (generate mode parentModule body) + + Opt.TrackedFunction args body -> + let + argNames : List (A.Located JsName.Name) + argNames = + List.map (\(A.At region name) -> A.At region (JsName.fromLocal name)) args + in + generateTrackedFunction parentModule argNames (generate mode parentModule body) + + Opt.Call (A.Region startPos _) func args -> + JsExpr <| generateCall mode parentModule startPos func args + + Opt.TailCall name args -> + JsBlock <| generateTailCall mode parentModule name args + + Opt.If branches final -> + generateIf mode parentModule branches final + + Opt.Let def body -> + JsBlock <| generateDef mode parentModule def :: codeToStmtList (generate mode parentModule body) + + Opt.Destruct (Opt.Destructor name path) body -> + let + pathDef : JS.Stmt + pathDef = + JS.Var (JsName.fromLocal name) (generatePath mode path) + in + JsBlock <| pathDef :: codeToStmtList (generate mode parentModule body) + + Opt.Case label root decider jumps -> + JsBlock <| generateCase mode parentModule label root decider jumps + + Opt.Accessor _ field -> + JsExpr <| + JS.ExprFunction Nothing + [ JsName.dollar ] + [ JS.Return <| + JS.ExprAccess (JS.ExprRef JsName.dollar) (generateField mode field) + ] + + Opt.Access record (A.Region startPos _) field -> + JsExpr <| JS.ExprTrackedAccess (generateJsExpr mode parentModule record) parentModule startPos (generateField mode field) + + Opt.Update region record fields -> + JsExpr <| + JS.ExprCall (JS.ExprRef (JsName.fromKernel Name.utils "update")) + [ generateJsExpr mode parentModule record + , generateTrackedRecord mode parentModule region fields + ] + + Opt.Record fields -> + JsExpr <| generateRecord mode parentModule fields + + Opt.TrackedRecord region fields -> + JsExpr <| generateTrackedRecord mode parentModule region fields + + Opt.Unit -> + case mode of + Mode.Dev _ -> + JsExpr <| JS.ExprRef (JsName.fromKernel Name.utils "Tuple0") + + Mode.Prod _ -> + JsExpr <| JS.ExprInt 0 + + Opt.Tuple _ a b cs -> + JsExpr <| + case cs of + [] -> + JS.ExprCall (JS.ExprRef (JsName.fromKernel Name.utils "Tuple2")) + [ generateJsExpr mode parentModule a + , generateJsExpr mode parentModule b + ] + + [ c ] -> + JS.ExprCall (JS.ExprRef (JsName.fromKernel Name.utils "Tuple3")) + [ generateJsExpr mode parentModule a + , generateJsExpr mode parentModule b + , generateJsExpr mode parentModule c + ] + + _ -> + JS.ExprCall (JS.ExprRef (JsName.fromKernel Name.utils "TupleN")) + (List.map (generateJsExpr mode parentModule) (a :: b :: cs)) + + Opt.Shader src attributes uniforms -> + let + toTranlation : Name.Name -> ( JsName.Name, JS.Expr ) + toTranlation field = + ( JsName.fromLocal field + , JS.ExprString (generateField mode field) + ) + + toTranslationObject : EverySet.EverySet String Name.Name -> JS.Expr + toTranslationObject fields = + JS.ExprObject (List.map toTranlation (EverySet.toList compare fields)) + in + JsExpr <| + JS.ExprObject + [ ( JsName.fromLocal "src", JS.ExprString (Shader.toJsStringBuilder src) ) + , ( JsName.fromLocal "attributes", toTranslationObject attributes ) + , ( JsName.fromLocal "uniforms", toTranslationObject uniforms ) + ] + + + +-- CODE CHUNKS + + +type Code + = JsExpr JS.Expr + | JsBlock (List JS.Stmt) + + +codeToExpr : Code -> JS.Expr +codeToExpr code = + case code of + JsExpr expr -> + expr + + JsBlock [ JS.Return expr ] -> + expr + + JsBlock stmts -> + JS.ExprCall (JS.ExprFunction Nothing [] stmts) [] + + +codeToStmtList : Code -> List JS.Stmt +codeToStmtList code = + case code of + JsExpr (JS.ExprCall (JS.ExprFunction Nothing [] stmts) []) -> + stmts + + JsExpr expr -> + [ JS.Return expr ] + + JsBlock stmts -> + stmts + + +codeToStmt : Code -> JS.Stmt +codeToStmt code = + case code of + JsExpr (JS.ExprCall (JS.ExprFunction Nothing [] stmts) []) -> + JS.Block stmts + + JsExpr expr -> + JS.Return expr + + JsBlock [ stmt ] -> + stmt + + JsBlock stmts -> + JS.Block stmts + + + +-- CHARS + + +toChar : JS.Expr +toChar = + JS.ExprRef (JsName.fromKernel Name.utils "chr") + + + +-- CTOR + + +generateCtor : Mode.Mode -> Opt.Global -> Index.ZeroBased -> Int -> Code +generateCtor mode (Opt.Global home name) index arity = + let + argNames : List JsName.Name + argNames = + Index.indexedMap (\i _ -> JsName.fromIndex i) (List.range 1 arity) + + ctorTag : JS.Expr + ctorTag = + case mode of + Mode.Dev _ -> + JS.ExprString name + + Mode.Prod _ -> + JS.ExprInt (ctorToInt home name index) + in + generateFunction argNames <| + JsExpr <| + JS.ExprObject + (( JsName.dollar, ctorTag ) :: List.map (\n -> ( n, JS.ExprRef n )) argNames) + + +ctorToInt : IO.Canonical -> Name.Name -> Index.ZeroBased -> Int +ctorToInt home name index = + if home == ModuleName.dict && (name == "RBNode_elm_builtin" || name == "RBEmpty_elm_builtin") then + -(Index.toHuman index) + + else + Index.toMachine index + + + +-- RECORDS + + +generateRecord : Mode.Mode -> IO.Canonical -> Dict String Name.Name Opt.Expr -> JS.Expr +generateRecord mode parentModule fields = + let + toPair : ( Name.Name, Opt.Expr ) -> ( JsName.Name, JS.Expr ) + toPair ( field, value ) = + ( generateField mode field, generateJsExpr mode parentModule value ) + in + JS.ExprObject (List.map toPair (Dict.toList compare fields)) + + +generateTrackedRecord : Mode.Mode -> IO.Canonical -> A.Region -> Dict String (A.Located Name.Name) Opt.Expr -> JS.Expr +generateTrackedRecord mode parentModule region fields = + let + toPair : ( A.Located Name.Name, Opt.Expr ) -> ( A.Located JsName.Name, JS.Expr ) + toPair ( A.At fieldRegion field, value ) = + ( A.At fieldRegion (generateField mode field), generateJsExpr mode parentModule value ) + in + JS.ExprTrackedObject parentModule region (List.map toPair (Dict.toList A.compareLocated fields)) + + +generateField : Mode.Mode -> Name.Name -> JsName.Name +generateField mode name = + case mode of + Mode.Dev _ -> + JsName.fromLocal name + + Mode.Prod fields -> + Utils.find identity name fields + + + +-- DEBUG + + +generateDebug : Name.Name -> IO.Canonical -> A.Region -> Maybe Name.Name -> JS.Expr +generateDebug name (IO.Canonical _ home) region unhandledValueName = + if name /= "todo" then + JS.ExprRef (JsName.fromGlobal ModuleName.debug name) + + else + case unhandledValueName of + Nothing -> + JS.ExprCall (JS.ExprRef (JsName.fromKernel Name.debug "todo")) + [ JS.ExprString home + , regionToJsExpr region + ] + + Just valueName -> + JS.ExprCall (JS.ExprRef (JsName.fromKernel Name.debug "todoCase")) + [ JS.ExprString home + , regionToJsExpr region + , JS.ExprRef (JsName.fromLocal valueName) + ] + + +regionToJsExpr : A.Region -> JS.Expr +regionToJsExpr (A.Region start end) = + JS.ExprObject + [ ( JsName.fromLocal "start", positionToJsExpr start ) + , ( JsName.fromLocal "end", positionToJsExpr end ) + ] + + +positionToJsExpr : A.Position -> JS.Expr +positionToJsExpr (A.Position line column) = + JS.ExprObject + [ ( JsName.fromLocal "line", JS.ExprInt line ) + , ( JsName.fromLocal "column", JS.ExprInt column ) + ] + + + +-- FUNCTION + + +generateFunction : List JsName.Name -> Code -> Code +generateFunction args body = + case Dict.get identity (List.length args) funcHelpers of + Just helper -> + JsExpr <| + JS.ExprCall helper + [ JS.ExprFunction Nothing args <| + codeToStmtList body + ] + + Nothing -> + let + addArg : JsName.Name -> Code -> Code + addArg arg code = + JsExpr <| + JS.ExprFunction Nothing [ arg ] <| + codeToStmtList code + in + List.foldr addArg body args + + +generateTrackedFunction : IO.Canonical -> List (A.Located JsName.Name) -> Code -> Code +generateTrackedFunction parentModule args body = + case Dict.get identity (List.length args) funcHelpers of + Just helper -> + JsExpr <| + JS.ExprCall + helper + [ JS.ExprTrackedFunction parentModule args <| + codeToStmtList body + ] + + Nothing -> + case args of + [ _ ] -> + JsExpr <| + JS.ExprTrackedFunction parentModule args <| + codeToStmtList body + + _ -> + let + addArg : JsName.Name -> Code -> Code + addArg arg code = + JsExpr <| + JS.ExprFunction Nothing [ arg ] <| + codeToStmtList code + in + List.foldr addArg body (List.map A.toValue args) + + +funcHelpers : Dict Int Int JS.Expr +funcHelpers = + Dict.fromList identity <| + List.map (\n -> ( n, JS.ExprRef (JsName.makeF n) )) (List.range 2 9) + + + +-- CALLS + + +generateCall : Mode.Mode -> IO.Canonical -> A.Position -> Opt.Expr -> List Opt.Expr -> JS.Expr +generateCall mode parentModule pos func args = + case func of + Opt.VarGlobal _ ((Opt.Global (IO.Canonical pkg _) _) as global) -> + if pkg == Pkg.core then + generateCoreCall mode parentModule pos global args + + else + generateCallHelp mode parentModule pos func args + + Opt.VarBox _ _ -> + case mode of + Mode.Dev _ -> + generateCallHelp mode parentModule pos func args + + Mode.Prod _ -> + case args of + [ arg ] -> + generateJsExpr mode parentModule arg + + _ -> + generateCallHelp mode parentModule pos func args + + _ -> + generateCallHelp mode parentModule pos func args + + +generateCallHelp : Mode.Mode -> IO.Canonical -> A.Position -> Opt.Expr -> List Opt.Expr -> JS.Expr +generateCallHelp mode parentModule pos func args = + generateNormalCall parentModule + pos + (generateJsExpr mode parentModule func) + (List.map (generateJsExpr mode parentModule) args) + + +generateGlobalCall : IO.Canonical -> A.Position -> IO.Canonical -> Name.Name -> List JS.Expr -> JS.Expr +generateGlobalCall parentModule ((A.Position line col) as pos) home name args = + -- generateNormalCall (JS.ExprRef (JsName.fromGlobal home name)) args + let + ref : JS.Expr + ref = + if line == 0 && col == 0 then + JS.ExprRef (JsName.fromGlobal home name) + + else + JS.ExprTrackedRef parentModule pos (JsName.fromGlobalHumanReadable home name) (JsName.fromGlobal home name) + in + generateNormalCall parentModule pos ref args + + +generateNormalCall : IO.Canonical -> A.Position -> JS.Expr -> List JS.Expr -> JS.Expr +generateNormalCall parentModule pos func args = + case Dict.get identity (List.length args) callHelpers of + Just helper -> + JS.ExprTrackedNormalCall parentModule pos helper func args + + Nothing -> + List.foldl (\a f -> JS.ExprCall f [ a ]) func args + + +callHelpers : Dict Int Int JS.Expr +callHelpers = + Dict.fromList identity <| + List.map (\n -> ( n, JS.ExprRef (JsName.makeA n) )) (List.range 2 9) + + + +-- CORE CALLS + + +generateCoreCall : Mode.Mode -> IO.Canonical -> A.Position -> Opt.Global -> List Opt.Expr -> JS.Expr +generateCoreCall mode parentModule pos (Opt.Global ((IO.Canonical _ moduleName) as home) name) args = + if moduleName == Name.basics then + generateBasicsCall mode parentModule pos home name args + + else if moduleName == Name.bitwise then + generateBitwiseCall parentModule pos home name (List.map (generateJsExpr mode parentModule) args) + + else if moduleName == Name.tuple then + generateTupleCall parentModule pos home name (List.map (generateJsExpr mode parentModule) args) + + else if moduleName == Name.jsArray then + generateJsArrayCall parentModule pos home name (List.map (generateJsExpr mode parentModule) args) + + else + generateGlobalCall parentModule pos home name (List.map (generateJsExpr mode parentModule) args) + + +generateTupleCall : IO.Canonical -> A.Position -> IO.Canonical -> Name.Name -> List JS.Expr -> JS.Expr +generateTupleCall parentModule pos home name args = + case args of + [ value ] -> + case name of + "first" -> + JS.ExprAccess value (JsName.fromLocal "a") + + "second" -> + JS.ExprAccess value (JsName.fromLocal "b") + + _ -> + generateGlobalCall parentModule pos home name args + + _ -> + generateGlobalCall parentModule pos home name args + + +generateJsArrayCall : IO.Canonical -> A.Position -> IO.Canonical -> Name.Name -> List JS.Expr -> JS.Expr +generateJsArrayCall parentModule pos home name args = + case ( args, name ) of + ( [ entry ], "singleton" ) -> + JS.ExprArray [ entry ] + + ( [ index, array ], "unsafeGet" ) -> + JS.ExprIndex array index + + _ -> + generateGlobalCall parentModule pos home name args + + +generateBitwiseCall : IO.Canonical -> A.Position -> IO.Canonical -> Name.Name -> List JS.Expr -> JS.Expr +generateBitwiseCall parentModule pos home name args = + case args of + [ arg ] -> + case name of + "complement" -> + JS.ExprPrefix JS.PrefixComplement arg + + _ -> + generateGlobalCall parentModule pos home name args + + [ left, right ] -> + case name of + "and" -> + JS.ExprInfix JS.OpBitwiseAnd left right + + "or" -> + JS.ExprInfix JS.OpBitwiseOr left right + + "xor" -> + JS.ExprInfix JS.OpBitwiseXor left right + + "shiftLeftBy" -> + JS.ExprInfix JS.OpLShift right left + + "shiftRightBy" -> + JS.ExprInfix JS.OpSpRShift right left + + "shiftRightZfBy" -> + JS.ExprInfix JS.OpZfRShift right left + + _ -> + generateGlobalCall parentModule pos home name args + + _ -> + generateGlobalCall parentModule pos home name args + + +generateBasicsCall : Mode.Mode -> IO.Canonical -> A.Position -> IO.Canonical -> Name.Name -> List Opt.Expr -> JS.Expr +generateBasicsCall mode parentModule pos home name args = + case args of + [ elmArg ] -> + let + arg : JS.Expr + arg = + generateJsExpr mode parentModule elmArg + in + case name of + "not" -> + JS.ExprPrefix JS.PrefixNot arg + + "negate" -> + JS.ExprPrefix JS.PrefixNegate arg + + "toFloat" -> + arg + + "truncate" -> + JS.ExprInfix JS.OpBitwiseOr arg (JS.ExprInt 0) + + _ -> + generateGlobalCall parentModule pos home name [ arg ] + + [ elmLeft, elmRight ] -> + case name of + -- NOTE: removed "composeL" and "composeR" because of this issue: + -- https://github.com/elm/compiler/issues/1722 + "append" -> + append mode parentModule elmLeft elmRight + + "apL" -> + generateJsExpr mode parentModule <| apply elmLeft elmRight + + "apR" -> + generateJsExpr mode parentModule <| apply elmRight elmLeft + + _ -> + let + left : JS.Expr + left = + generateJsExpr mode parentModule elmLeft + + right : JS.Expr + right = + generateJsExpr mode parentModule elmRight + in + case name of + "add" -> + JS.ExprInfix JS.OpAdd left right + + "sub" -> + JS.ExprInfix JS.OpSub left right + + "mul" -> + JS.ExprInfix JS.OpMul left right + + "fdiv" -> + JS.ExprInfix JS.OpDiv left right + + "idiv" -> + JS.ExprInfix JS.OpBitwiseOr (JS.ExprInfix JS.OpDiv left right) (JS.ExprInt 0) + + "eq" -> + equal left right + + "neq" -> + notEqual left right + + "lt" -> + cmp JS.OpLt JS.OpLt 0 left right + + "gt" -> + cmp JS.OpGt JS.OpGt 0 left right + + "le" -> + cmp JS.OpLe JS.OpLt 1 left right + + "ge" -> + cmp JS.OpGe JS.OpGt -1 left right + + "or" -> + JS.ExprInfix JS.OpOr left right + + "and" -> + JS.ExprInfix JS.OpAnd left right + + "xor" -> + JS.ExprInfix JS.OpNe left right + + "remainderBy" -> + JS.ExprInfix JS.OpMod right left + + _ -> + generateGlobalCall parentModule pos home name [ left, right ] + + _ -> + generateGlobalCall parentModule pos home name <| List.map (generateJsExpr mode parentModule) args + + +equal : JS.Expr -> JS.Expr -> JS.Expr +equal left right = + if isLiteral left || isLiteral right then + strictEq left right + + else + JS.ExprCall (JS.ExprRef (JsName.fromKernel Name.utils "eq")) [ left, right ] + + +notEqual : JS.Expr -> JS.Expr -> JS.Expr +notEqual left right = + if isLiteral left || isLiteral right then + strictNEq left right + + else + JS.ExprPrefix JS.PrefixNot <| JS.ExprCall (JS.ExprRef (JsName.fromKernel Name.utils "eq")) [ left, right ] + + +cmp : JS.InfixOp -> JS.InfixOp -> Int -> JS.Expr -> JS.Expr -> JS.Expr +cmp idealOp backupOp backupInt left right = + if isLiteral left || isLiteral right then + JS.ExprInfix idealOp left right + + else + JS.ExprInfix backupOp + (JS.ExprCall (JS.ExprRef (JsName.fromKernel Name.utils "cmp")) [ left, right ]) + (JS.ExprInt backupInt) + + +isLiteral : JS.Expr -> Bool +isLiteral expr = + case expr of + JS.ExprString _ -> + True + + JS.ExprTrackedString _ _ _ -> + True + + JS.ExprFloat _ -> + True + + JS.ExprTrackedFloat _ _ _ -> + True + + JS.ExprInt _ -> + True + + JS.ExprTrackedInt _ _ _ -> + True + + JS.ExprBool _ -> + True + + JS.ExprTrackedBool _ _ _ -> + True + + _ -> + False + + +apply : Opt.Expr -> Opt.Expr -> Opt.Expr +apply func value = + case func of + Opt.Accessor region field -> + Opt.Access value region field + + Opt.Call region f args -> + Opt.Call region f (args ++ [ value ]) + + _ -> + Opt.Call (Maybe.withDefault A.zero (exprRegion func)) func [ value ] + + +exprRegion : Opt.Expr -> Maybe A.Region +exprRegion expr = + case expr of + Opt.Bool region _ -> + Just region + + Opt.Chr region _ -> + Just region + + Opt.Str region _ -> + Just region + + Opt.Int region _ -> + Just region + + Opt.Float region _ -> + Just region + + Opt.VarLocal _ -> + Nothing + + Opt.TrackedVarLocal region _ -> + Just region + + Opt.VarGlobal region _ -> + Just region + + Opt.VarEnum region _ _ -> + Just region + + Opt.VarBox region _ -> + Just region + + Opt.VarCycle region _ _ -> + Just region + + Opt.VarDebug region _ _ _ -> + Just region + + Opt.VarKernel region _ _ -> + Just region + + Opt.List region _ -> + Just region + + Opt.Function _ _ -> + Nothing + + Opt.TrackedFunction _ _ -> + Nothing + + Opt.Call region _ _ -> + Just region + + Opt.TailCall _ _ -> + Nothing + + Opt.If _ _ -> + Nothing + + Opt.Let _ _ -> + Nothing + + Opt.Destruct _ _ -> + Nothing + + Opt.Case _ _ _ _ -> + Nothing + + Opt.Accessor region _ -> + Just region + + Opt.Access _ region _ -> + Just region + + Opt.Update region _ _ -> + Just region + + Opt.Record _ -> + Nothing + + Opt.TrackedRecord region _ -> + Just region + + Opt.Unit -> + Nothing + + Opt.Tuple region _ _ _ -> + Just region + + Opt.Shader _ _ _ -> + Nothing + + +append : Mode.Mode -> IO.Canonical -> Opt.Expr -> Opt.Expr -> JS.Expr +append mode parentModule left right = + let + seqs : List JS.Expr + seqs = + generateJsExpr mode parentModule left :: toSeqs mode parentModule right + in + if List.any isStringLiteral seqs then + Utils.foldr1 (JS.ExprInfix JS.OpAdd) seqs + + else + Utils.foldr1 jsAppend seqs + + +jsAppend : JS.Expr -> JS.Expr -> JS.Expr +jsAppend a b = + JS.ExprCall (JS.ExprRef (JsName.fromKernel Name.utils "ap")) [ a, b ] + + +toSeqs : Mode.Mode -> IO.Canonical -> Opt.Expr -> List JS.Expr +toSeqs mode parentModule expr = + case expr of + Opt.Call _ (Opt.VarGlobal _ (Opt.Global home "append")) [ left, right ] -> + if home == ModuleName.basics then + generateJsExpr mode parentModule left :: toSeqs mode parentModule right + + else + [ generateJsExpr mode parentModule expr ] + + _ -> + [ generateJsExpr mode parentModule expr ] + + +isStringLiteral : JS.Expr -> Bool +isStringLiteral expr = + case expr of + JS.ExprString _ -> + True + + JS.ExprTrackedString _ _ _ -> + True + + _ -> + False + + + +-- SIMPLIFY INFIX OPERATORS + + +strictEq : JS.Expr -> JS.Expr -> JS.Expr +strictEq left right = + case left of + JS.ExprInt 0 -> + JS.ExprPrefix JS.PrefixNot right + + JS.ExprTrackedInt _ _ 0 -> + JS.ExprPrefix JS.PrefixNot right + + JS.ExprBool bool -> + if bool then + right + + else + JS.ExprPrefix JS.PrefixNot right + + JS.ExprTrackedBool _ _ bool -> + if bool then + right + + else + JS.ExprPrefix JS.PrefixNot right + + _ -> + case right of + JS.ExprInt 0 -> + JS.ExprPrefix JS.PrefixNot left + + JS.ExprTrackedInt _ _ 0 -> + JS.ExprPrefix JS.PrefixNot left + + JS.ExprBool bool -> + if bool then + left + + else + JS.ExprPrefix JS.PrefixNot left + + JS.ExprTrackedBool _ _ bool -> + if bool then + left + + else + JS.ExprPrefix JS.PrefixNot left + + _ -> + JS.ExprInfix JS.OpEq left right + + +strictNEq : JS.Expr -> JS.Expr -> JS.Expr +strictNEq left right = + case left of + JS.ExprInt 0 -> + JS.ExprPrefix JS.PrefixNot (JS.ExprPrefix JS.PrefixNot right) + + JS.ExprTrackedInt _ _ 0 -> + JS.ExprPrefix JS.PrefixNot (JS.ExprPrefix JS.PrefixNot right) + + JS.ExprBool bool -> + if bool then + JS.ExprPrefix JS.PrefixNot right + + else + right + + JS.ExprTrackedBool _ _ bool -> + if bool then + JS.ExprPrefix JS.PrefixNot right + + else + right + + _ -> + case right of + JS.ExprInt 0 -> + JS.ExprPrefix JS.PrefixNot (JS.ExprPrefix JS.PrefixNot left) + + JS.ExprTrackedInt _ _ 0 -> + JS.ExprPrefix JS.PrefixNot (JS.ExprPrefix JS.PrefixNot left) + + JS.ExprBool bool -> + if bool then + JS.ExprPrefix JS.PrefixNot left + + else + left + + JS.ExprTrackedBool _ _ bool -> + if bool then + JS.ExprPrefix JS.PrefixNot left + + else + left + + _ -> + JS.ExprInfix JS.OpNe left right + + + +-- TAIL CALL + + +{-| TODO check if JS minifiers collapse unnecessary temporary variables +-} +generateTailCall : Mode.Mode -> IO.Canonical -> Name.Name -> List ( Name.Name, Opt.Expr ) -> List JS.Stmt +generateTailCall mode parentModule name args = + let + toTempVars : ( String, Opt.Expr ) -> ( JsName.Name, JS.Expr ) + toTempVars ( argName, arg ) = + ( JsName.makeTemp argName, generateJsExpr mode parentModule arg ) + + toRealVars : ( Name.Name, b ) -> JS.Stmt + toRealVars ( argName, _ ) = + JS.ExprStmt <| JS.ExprAssign (JS.LRef (JsName.fromLocal argName)) (JS.ExprRef (JsName.makeTemp argName)) + in + JS.Vars (List.map toTempVars args) + :: List.map toRealVars args + ++ [ JS.Continue (Just (JsName.fromLocal name)) ] + + + +-- DEFINITIONS + + +generateDef : Mode.Mode -> IO.Canonical -> Opt.Def -> JS.Stmt +generateDef mode parentModule def = + case def of + Opt.Def (A.Region start _) name body -> + JS.TrackedVar parentModule start (JsName.fromLocal name) (JsName.fromLocal name) (generateJsExpr mode parentModule body) + + Opt.TailDef (A.Region start _) name argNames body -> + JS.TrackedVar parentModule start (JsName.fromLocal name) (JsName.fromLocal name) (codeToExpr (generateTailDef mode parentModule name argNames body)) + + +generateTailDef : Mode.Mode -> IO.Canonical -> Name.Name -> List (A.Located Name.Name) -> Opt.Expr -> Code +generateTailDef mode parentModule name argNames body = + generateTrackedFunction parentModule (List.map (\(A.At region argName) -> A.At region (JsName.fromLocal argName)) argNames) <| + JsBlock + [ JS.Labelled (JsName.fromLocal name) <| + JS.While (JS.ExprBool True) <| + codeToStmt <| + generate mode parentModule body + ] + + + +-- PATHS + + +generatePath : Mode.Mode -> Opt.Path -> JS.Expr +generatePath mode path = + case path of + Opt.Index index subPath -> + JS.ExprAccess (generatePath mode subPath) (JsName.fromIndex index) + + Opt.ArrayIndex index subPath -> + JS.ExprIndex (generatePath mode subPath) (JS.ExprInt index) + + Opt.Root name -> + JS.ExprRef (JsName.fromLocal name) + + Opt.Field field subPath -> + JS.ExprAccess (generatePath mode subPath) (generateField mode field) + + Opt.Unbox subPath -> + case mode of + Mode.Dev _ -> + JS.ExprAccess (generatePath mode subPath) (JsName.fromIndex Index.first) + + Mode.Prod _ -> + generatePath mode subPath + + + +-- GENERATE IFS + + +generateIf : Mode.Mode -> IO.Canonical -> List ( Opt.Expr, Opt.Expr ) -> Opt.Expr -> Code +generateIf mode parentModule givenBranches givenFinal = + let + ( branches, final ) = + crushIfs givenBranches givenFinal + + convertBranch : ( Opt.Expr, Opt.Expr ) -> ( JS.Expr, Code ) + convertBranch ( condition, expr ) = + ( generateJsExpr mode parentModule condition + , generate mode parentModule expr + ) + + branchExprs : List ( JS.Expr, Code ) + branchExprs = + List.map convertBranch branches + + finalCode : Code + finalCode = + generate mode parentModule final + in + if isBlock finalCode || List.any (isBlock << Tuple.second) branchExprs then + JsBlock [ List.foldr addStmtIf (codeToStmt finalCode) branchExprs ] + + else + JsExpr (List.foldr addExprIf (codeToExpr finalCode) branchExprs) + + +addExprIf : ( JS.Expr, Code ) -> JS.Expr -> JS.Expr +addExprIf ( condition, branch ) final = + JS.ExprIf condition (codeToExpr branch) final + + +addStmtIf : ( JS.Expr, Code ) -> JS.Stmt -> JS.Stmt +addStmtIf ( condition, branch ) final = + JS.IfStmt condition (codeToStmt branch) final + + +isBlock : Code -> Bool +isBlock code = + case code of + JsBlock _ -> + True + + JsExpr _ -> + False + + +crushIfs : List ( Opt.Expr, Opt.Expr ) -> Opt.Expr -> ( List ( Opt.Expr, Opt.Expr ), Opt.Expr ) +crushIfs branches final = + crushIfsHelp [] branches final + + +crushIfsHelp : + List ( Opt.Expr, Opt.Expr ) + -> List ( Opt.Expr, Opt.Expr ) + -> Opt.Expr + -> ( List ( Opt.Expr, Opt.Expr ), Opt.Expr ) +crushIfsHelp visitedBranches unvisitedBranches final = + case unvisitedBranches of + [] -> + case final of + Opt.If subBranches subFinal -> + crushIfsHelp visitedBranches subBranches subFinal + + _ -> + ( List.reverse visitedBranches, final ) + + visiting :: unvisited -> + crushIfsHelp (visiting :: visitedBranches) unvisited final + + + +-- CASE EXPRESSIONS + + +generateCase : Mode.Mode -> IO.Canonical -> Name.Name -> Name.Name -> Opt.Decider Opt.Choice -> List ( Int, Opt.Expr ) -> List JS.Stmt +generateCase mode parentModule label root decider jumps = + List.foldr (goto mode parentModule label) (generateDecider mode parentModule label root decider) jumps + + +goto : Mode.Mode -> IO.Canonical -> Name.Name -> ( Int, Opt.Expr ) -> List JS.Stmt -> List JS.Stmt +goto mode parentModule label ( index, branch ) stmts = + let + labeledDeciderStmt : JS.Stmt + labeledDeciderStmt = + JS.Labelled + (JsName.makeLabel label index) + (JS.While (JS.ExprBool True) (JS.Block stmts)) + in + labeledDeciderStmt :: codeToStmtList (generate mode parentModule branch) + + +generateDecider : Mode.Mode -> IO.Canonical -> Name.Name -> Name.Name -> Opt.Decider Opt.Choice -> List JS.Stmt +generateDecider mode parentModule label root decisionTree = + case decisionTree of + Opt.Leaf (Opt.Inline branch) -> + codeToStmtList (generate mode parentModule branch) + + Opt.Leaf (Opt.Jump index) -> + [ JS.Break (Just (JsName.makeLabel label index)) ] + + Opt.Chain testChain success failure -> + [ JS.IfStmt + (Utils.foldl1_ (JS.ExprInfix JS.OpAnd) (List.map (generateIfTest mode root) testChain)) + (JS.Block (generateDecider mode parentModule label root success)) + (JS.Block (generateDecider mode parentModule label root failure)) + ] + + Opt.FanOut path edges fallback -> + [ JS.Switch + (generateCaseTest mode root path (Tuple.first (Prelude.head edges))) + (List.foldr + (\edge cases -> generateCaseBranch mode parentModule label root edge :: cases) + [ JS.Default (generateDecider mode parentModule label root fallback) ] + edges + ) + ] + + +generateIfTest : Mode.Mode -> Name.Name -> ( DT.Path, DT.Test ) -> JS.Expr +generateIfTest mode root ( path, test ) = + let + value : JS.Expr + value = + pathToJsExpr mode root path + in + case test of + DT.IsCtor home name index _ opts -> + let + tag : JS.Expr + tag = + case mode of + Mode.Dev _ -> + JS.ExprAccess value JsName.dollar + + Mode.Prod _ -> + case opts of + Can.Normal -> + JS.ExprAccess value JsName.dollar + + Can.Enum -> + value + + Can.Unbox -> + value + in + strictEq tag + (case mode of + Mode.Dev _ -> + JS.ExprString name + + Mode.Prod _ -> + JS.ExprInt (ctorToInt home name index) + ) + + DT.IsBool True -> + value + + DT.IsBool False -> + JS.ExprPrefix JS.PrefixNot value + + DT.IsInt int -> + strictEq value (JS.ExprInt int) + + DT.IsChr char -> + strictEq (JS.ExprString char) + (case mode of + Mode.Dev _ -> + JS.ExprCall (JS.ExprAccess value (JsName.fromLocal "valueOf")) [] + + Mode.Prod _ -> + value + ) + + DT.IsStr string -> + strictEq value (JS.ExprString string) + + DT.IsCons -> + JS.ExprAccess value (JsName.fromLocal "b") + + DT.IsNil -> + JS.ExprPrefix JS.PrefixNot <| + JS.ExprAccess value (JsName.fromLocal "b") + + DT.IsTuple -> + crash "COMPILER BUG - there should never be tests on a tuple" + + +generateCaseBranch : Mode.Mode -> IO.Canonical -> Name.Name -> Name.Name -> ( DT.Test, Opt.Decider Opt.Choice ) -> JS.Case +generateCaseBranch mode parentModule label root ( test, subTree ) = + JS.Case + (generateCaseValue mode test) + (generateDecider mode parentModule label root subTree) + + +generateCaseValue : Mode.Mode -> DT.Test -> JS.Expr +generateCaseValue mode test = + case test of + DT.IsCtor home name index _ _ -> + case mode of + Mode.Dev _ -> + JS.ExprString name + + Mode.Prod _ -> + JS.ExprInt (ctorToInt home name index) + + DT.IsInt int -> + JS.ExprInt int + + DT.IsChr char -> + JS.ExprString char + + DT.IsStr string -> + JS.ExprString string + + DT.IsBool _ -> + crash "COMPILER BUG - there should never be three tests on a boolean" + + DT.IsCons -> + crash "COMPILER BUG - there should never be three tests on a list" + + DT.IsNil -> + crash "COMPILER BUG - there should never be three tests on a list" + + DT.IsTuple -> + crash "COMPILER BUG - there should never be three tests on a tuple" + + +generateCaseTest : Mode.Mode -> Name.Name -> DT.Path -> DT.Test -> JS.Expr +generateCaseTest mode root path exampleTest = + let + value : JS.Expr + value = + pathToJsExpr mode root path + in + case exampleTest of + DT.IsCtor home name _ _ opts -> + if name == Name.bool && home == ModuleName.basics then + value + + else + case mode of + Mode.Dev _ -> + JS.ExprAccess value JsName.dollar + + Mode.Prod _ -> + case opts of + Can.Normal -> + JS.ExprAccess value JsName.dollar + + Can.Enum -> + value + + Can.Unbox -> + value + + DT.IsInt _ -> + value + + DT.IsStr _ -> + value + + DT.IsChr _ -> + case mode of + Mode.Dev _ -> + JS.ExprCall (JS.ExprAccess value (JsName.fromLocal "valueOf")) [] + + Mode.Prod _ -> + value + + DT.IsBool _ -> + crash "COMPILER BUG - there should never be three tests on a list" + + DT.IsCons -> + crash "COMPILER BUG - there should never be three tests on a list" + + DT.IsNil -> + crash "COMPILER BUG - there should never be three tests on a list" + + DT.IsTuple -> + crash "COMPILER BUG - there should never be three tests on a list" + + + +-- PATTERN PATHS + + +pathToJsExpr : Mode.Mode -> Name.Name -> DT.Path -> JS.Expr +pathToJsExpr mode root path = + case path of + DT.Index index subPath -> + JS.ExprAccess (pathToJsExpr mode root subPath) (JsName.fromIndex index) + + DT.Unbox subPath -> + case mode of + Mode.Dev _ -> + JS.ExprAccess (pathToJsExpr mode root subPath) (JsName.fromIndex Index.first) + + Mode.Prod _ -> + pathToJsExpr mode root subPath + + DT.Empty -> + JS.ExprRef (JsName.fromLocal root) + + + +-- GENERATE MAIN + + +generateMain : Mode.Mode -> IO.Canonical -> Opt.Main -> JS.Expr +generateMain mode home main = + case main of + Opt.Static -> + JS.ExprRef (JsName.fromKernel Name.virtualDom "init") + |> call (JS.ExprRef (JsName.fromGlobal home "main")) + |> call (JS.ExprInt 0) + |> call (JS.ExprInt 0) + + Opt.Dynamic msgType decoder -> + JS.ExprRef (JsName.fromGlobal home "main") + |> call (generateJsExpr mode home decoder) + |> call (toDebugMetadata mode msgType) + + +call : JS.Expr -> JS.Expr -> JS.Expr +call arg func = + JS.ExprCall func [ arg ] + + +toDebugMetadata : Mode.Mode -> Can.Type -> JS.Expr +toDebugMetadata mode msgType = + case mode of + Mode.Prod _ -> + JS.ExprInt 0 + + Mode.Dev Nothing -> + JS.ExprInt 0 + + Mode.Dev (Just interfaces) -> + JS.ExprJson + (Encode.object + [ ( "versions", Encode.object [ ( "elm", V.encode V.elmCompiler ) ] ) + , ( "types", Type.encodeMetadata (Extract.fromMsg interfaces msgType) ) + ] + ) diff --git a/compiler/src/Generate/JavaScript/Functions.hs b/src/Compiler/Generate/JavaScript/Functions.elm similarity index 91% rename from compiler/src/Generate/JavaScript/Functions.hs rename to src/Compiler/Generate/JavaScript/Functions.elm index 49951f72b7..f29e6cf7e9 100644 --- a/compiler/src/Generate/JavaScript/Functions.hs +++ b/src/Compiler/Generate/JavaScript/Functions.elm @@ -1,20 +1,11 @@ -{-# LANGUAGE OverloadedStrings, QuasiQuotes #-} -module Generate.JavaScript.Functions - ( functions - ) - where - - -import qualified Data.ByteString.Builder as B -import Text.RawString.QQ (r) - - +module Compiler.Generate.JavaScript.Functions exposing (functions) -- FUNCTIONS -functions :: B.Builder -functions = [r| +functions : String +functions = + """ function F(arity, fun, wrapper) { wrapper.a = arity; @@ -92,4 +83,4 @@ function A9(fun, a, b, c, d, e, f, g, h, i) { return fun.a === 9 ? fun.f(a, b, c, d, e, f, g, h, i) : fun(a)(b)(c)(d)(e)(f)(g)(h)(i); } -|] +""" diff --git a/src/Compiler/Generate/JavaScript/Name.elm b/src/Compiler/Generate/JavaScript/Name.elm new file mode 100644 index 0000000000..3deacdae80 --- /dev/null +++ b/src/Compiler/Generate/JavaScript/Name.elm @@ -0,0 +1,372 @@ +module Compiler.Generate.JavaScript.Name exposing + ( Name + , dollar + , fromCycle + , fromGlobal + , fromGlobalHumanReadable + , fromIndex + , fromInt + , fromKernel + , fromLocal + , fromLocalHumanReadable + , makeA + , makeF + , makeLabel + , makeTemp + ) + +import Compiler.Data.Index as Index +import Compiler.Data.Name as Name +import Data.Map as Dict exposing (Dict) +import Data.Set as EverySet exposing (EverySet) +import System.TypeCheck.IO as IO + + + +-- NAME + + +type alias Name = + String + + + +-- CONSTRUCTORS + + +fromIndex : Index.ZeroBased -> Name +fromIndex index = + fromInt (Index.toMachine index) + + +fromInt : Int -> Name +fromInt n = + intToAscii n + + +fromLocal : Name.Name -> Name +fromLocal name = + if EverySet.member identity name reservedNames then + "_" ++ name + + else + name + + +fromLocalHumanReadable : Name.Name -> Name +fromLocalHumanReadable name = + name + + +fromGlobal : IO.Canonical -> Name.Name -> Name +fromGlobal home name = + homeToBuilder home ++ usd ++ name + + +fromGlobalHumanReadable : IO.Canonical -> Name.Name -> Name +fromGlobalHumanReadable (IO.Canonical _ moduleName) name = + moduleName ++ "." ++ name + + +fromCycle : IO.Canonical -> Name.Name -> Name +fromCycle home name = + homeToBuilder home ++ "$cyclic$" ++ name + + +fromKernel : Name.Name -> Name.Name -> Name +fromKernel home name = + "_" ++ home ++ "_" ++ name + + +homeToBuilder : IO.Canonical -> String +homeToBuilder (IO.Canonical ( author, project ) home) = + usd + ++ String.replace "-" "_" author + ++ usd + ++ String.replace "-" "_" project + ++ usd + ++ String.replace "." "$" home + + + +-- TEMPORARY NAMES + + +makeF : Int -> Name +makeF n = + "F" ++ String.fromInt n + + +makeA : Int -> Name +makeA n = + "A" ++ String.fromInt n + + +makeLabel : String -> Int -> Name +makeLabel name index = + name ++ usd ++ String.fromInt index + + +makeTemp : String -> Name +makeTemp name = + "$temp$" ++ name + + +dollar : Name +dollar = + usd + + +usd : String +usd = + Name.dollar + + + +-- RESERVED NAMES + + +reservedNames : EverySet String String +reservedNames = + EverySet.union jsReservedWords elmReservedWords + + +jsReservedWords : EverySet String String +jsReservedWords = + EverySet.fromList identity + [ "do" + , "if" + , "in" + , "NaN" + , "int" + , "for" + , "new" + , "try" + , "var" + , "let" + , "null" + , "true" + , "eval" + , "byte" + , "char" + , "goto" + , "long" + , "case" + , "else" + , "this" + , "void" + , "with" + , "enum" + , "false" + , "final" + , "float" + , "short" + , "break" + , "catch" + , "throw" + , "while" + , "class" + , "const" + , "super" + , "yield" + , "double" + , "native" + , "throws" + , "delete" + , "return" + , "switch" + , "typeof" + , "export" + , "import" + , "public" + , "static" + , "boolean" + , "default" + , "finally" + , "extends" + , "package" + , "private" + , "Infinity" + , "abstract" + , "volatile" + , "function" + , "continue" + , "debugger" + , "function" + , "undefined" + , "arguments" + , "transient" + , "interface" + , "protected" + , "instanceof" + , "implements" + , "synchronized" + ] + + +elmReservedWords : EverySet String String +elmReservedWords = + EverySet.fromList identity + [ "F2" + , "F3" + , "F4" + , "F5" + , "F6" + , "F7" + , "F8" + , "F9" + , "A2" + , "A3" + , "A4" + , "A5" + , "A6" + , "A7" + , "A8" + , "A9" + ] + + + +-- INT TO ASCII + + +intToAscii : Int -> Name.Name +intToAscii n = + if n < 53 then + -- skip $ as a standalone name + Name.fromWords [ toByte n ] + + else + intToAsciiHelp 2 (numStartBytes * numInnerBytes) allBadFields (n - 53) + + +intToAsciiHelp : Int -> Int -> List BadFields -> Int -> Name.Name +intToAsciiHelp width blockSize badFields n = + case badFields of + [] -> + if n < blockSize then + unsafeIntToAscii width [] n + + else + intToAsciiHelp (width + 1) (blockSize * numInnerBytes) [] (n - blockSize) + + (BadFields renamings) :: biggerBadFields -> + let + availableSize : Int + availableSize = + blockSize - Dict.size renamings + in + if n < availableSize then + let + name : Name.Name + name = + unsafeIntToAscii width [] n + in + Dict.get identity name renamings |> Maybe.withDefault name + + else + intToAsciiHelp (width + 1) (blockSize * numInnerBytes) biggerBadFields (n - availableSize) + + + +-- UNSAFE INT TO ASCII + + +unsafeIntToAscii : Int -> List Char -> Int -> Name.Name +unsafeIntToAscii width bytes n = + if width <= 1 then + Name.fromWords (toByte n :: bytes) + + else + let + quotient : Int + quotient = + n // numInnerBytes + + remainder : Int + remainder = + n - (numInnerBytes * quotient) + in + unsafeIntToAscii (width - 1) (toByte remainder :: bytes) quotient + + + +-- ASCII BYTES + + +numStartBytes : Int +numStartBytes = + 54 + + +numInnerBytes : Int +numInnerBytes = + 64 + + +toByte : Int -> Char +toByte n = + if n < 26 then + -- lower + Char.fromCode (97 + n) + + else if n < 52 then + -- upper + Char.fromCode (65 + n - 26) + + else if n == 52 then + -- _ + Char.fromCode 95 + + else if n == 53 then + -- $ + Char.fromCode 36 + + else if n < 64 then + -- digit + Char.fromCode (48 + n - 54) + + else + -- crash ("cannot convert int " ++ String.fromInt n ++ " to ASCII") + Char.fromCode n + + + +-- BAD FIELDS + + +type BadFields + = BadFields Renamings + + +type alias Renamings = + Dict String Name.Name Name.Name + + +allBadFields : List BadFields +allBadFields = + let + add : String -> Dict Int Int BadFields -> Dict Int Int BadFields + add keyword dict = + Dict.update identity (String.length keyword) (Just << addRenaming keyword) dict + in + Dict.values compare (EverySet.foldr compare add Dict.empty jsReservedWords) + + +addRenaming : String -> Maybe BadFields -> BadFields +addRenaming keyword maybeBadFields = + let + width : Int + width = + String.length keyword + + maxName : Int + maxName = + numStartBytes * numInnerBytes ^ (width - 1) - 1 + in + case maybeBadFields of + Nothing -> + BadFields (Dict.singleton identity keyword (unsafeIntToAscii width [] maxName)) + + Just (BadFields renamings) -> + BadFields (Dict.insert identity keyword (unsafeIntToAscii width [] (maxName - Dict.size renamings)) renamings) diff --git a/src/Compiler/Generate/JavaScript/SourceMap.elm b/src/Compiler/Generate/JavaScript/SourceMap.elm new file mode 100644 index 0000000000..823908471e --- /dev/null +++ b/src/Compiler/Generate/JavaScript/SourceMap.elm @@ -0,0 +1,249 @@ +module Compiler.Generate.JavaScript.SourceMap exposing (generate) + +import Base64 +import Compiler.Elm.ModuleName as ModuleName +import Compiler.Generate.JavaScript.Builder as JS +import Compiler.Generate.JavaScript.Name as JSName +import Data.Map as Dict exposing (Dict) +import Json.Encode as Encode +import System.TypeCheck.IO as IO +import Utils.Main as Utils +import VLQ + + +generate : Int -> Int -> Dict (List String) IO.Canonical String -> List JS.Mapping -> String +generate leadingLines kernelLeadingLines moduleSources mappings = + "\n" + ++ "//# sourceMappingURL=data:application/json;base64," + ++ generateHelp leadingLines kernelLeadingLines moduleSources mappings + + +generateHelp : Int -> Int -> Dict (List String) IO.Canonical String -> List JS.Mapping -> String +generateHelp leadingLines kernelLeadingLines moduleSources mappings = + mappings + |> List.map + (\(JS.Mapping srcLine srcCol srcModule srcName genLine genCol) -> + JS.Mapping srcLine srcCol srcModule srcName (genLine + leadingLines + kernelLeadingLines) genCol + ) + |> parseMappings + |> mappingsToJson moduleSources + |> Encode.encode 4 + |> Base64.encode + + +type Mappings + = Mappings (OrderedListBuilder (List String) IO.Canonical) (OrderedListBuilder String JSName.Name) SegmentAccounting String + + +type SegmentAccounting + = SegmentAccounting (Maybe Int) (Maybe Int) (Maybe Int) (Maybe Int) (Maybe Int) + + +parseMappings : List JS.Mapping -> Mappings +parseMappings mappings = + let + mappingMap : Dict Int Int (List JS.Mapping) + mappingMap = + List.foldr + (\((JS.Mapping _ _ _ _ genLine _) as mapping) acc -> + Dict.update identity genLine (mappingMapUpdater mapping) acc + ) + Dict.empty + mappings + in + parseMappingsHelp 1 (Tuple.first (Utils.findMax compare mappingMap)) mappingMap <| + Mappings emptyOrderedListBuilder emptyOrderedListBuilder (SegmentAccounting Nothing Nothing Nothing Nothing Nothing) "" + + +mappingMapUpdater : JS.Mapping -> Maybe (List JS.Mapping) -> Maybe (List JS.Mapping) +mappingMapUpdater toInsert maybeVal = + case maybeVal of + Nothing -> + Just [ toInsert ] + + Just existing -> + Just (toInsert :: existing) + + +parseMappingsHelp : Int -> Int -> Dict Int Int (List JS.Mapping) -> Mappings -> Mappings +parseMappingsHelp currentLine lastLine mappingMap acc = + if currentLine > lastLine then + acc + + else + case Dict.get identity currentLine mappingMap of + Nothing -> + parseMappingsHelp (currentLine + 1) + lastLine + mappingMap + (prepareForNewLine acc) + + Just segments -> + let + sortedSegments : List JS.Mapping + sortedSegments = + List.sortBy (\(JS.Mapping _ _ _ _ _ genCol) -> -genCol) segments + in + parseMappingsHelp (currentLine + 1) + lastLine + mappingMap + (prepareForNewLine (List.foldr encodeSegment acc sortedSegments)) + + +prepareForNewLine : Mappings -> Mappings +prepareForNewLine (Mappings srcs nms (SegmentAccounting _ saPrevSourceIdx saPrevSourceLine saPrevSourceCol saPrevNameIdx) vlqs) = + Mappings + srcs + nms + (SegmentAccounting Nothing saPrevSourceIdx saPrevSourceLine saPrevSourceCol saPrevNameIdx) + (vlqs ++ ";") + + +encodeSegment : JS.Mapping -> Mappings -> Mappings +encodeSegment (JS.Mapping segmentSrcLine segmentSrcCol segmentSrcModule segmentSrcName _ segmentGenCol) (Mappings srcs nms (SegmentAccounting saPrevCol saPrevSourceIdx saPrevSourceLine saPrevSourceCol saPrevNameIdx) vlqs) = + let + newSources : OrderedListBuilder (List String) IO.Canonical + newSources = + insertIntoOrderedListBuilder ModuleName.toComparableCanonical segmentSrcModule srcs + + genCol : Int + genCol = + segmentGenCol - 1 + + moduleIdx : Int + moduleIdx = + Maybe.withDefault 0 (lookupIndexOrderedListBuilder ModuleName.toComparableCanonical segmentSrcModule newSources) + + sourceLine : Int + sourceLine = + segmentSrcLine - 1 + + sourceCol : Int + sourceCol = + segmentSrcCol - 1 + + genColDelta : Int + genColDelta = + genCol - Maybe.withDefault 0 saPrevCol + + moduleIdxDelta : Int + moduleIdxDelta = + moduleIdx - Maybe.withDefault 0 saPrevSourceIdx + + sourceLineDelta : Int + sourceLineDelta = + sourceLine - Maybe.withDefault 0 saPrevSourceLine + + sourceColDelta : Int + sourceColDelta = + sourceCol - Maybe.withDefault 0 saPrevSourceCol + + ((SegmentAccounting updatedSaPrevCol updatedSaPrevSourceIdx updatedSaPrevSourceLine updatedSaPrevSourceCol _) as updatedSa) = + SegmentAccounting (Just genCol) (Just moduleIdx) (Just sourceLine) (Just sourceCol) saPrevNameIdx + + vlqPrefix : String + vlqPrefix = + case saPrevCol of + Nothing -> + "" + + Just _ -> + "," + in + case segmentSrcName of + Just segmentName -> + let + newNames : OrderedListBuilder JSName.Name JSName.Name + newNames = + insertIntoOrderedListBuilder identity segmentName nms + + nameIdx : Int + nameIdx = + Maybe.withDefault 0 (lookupIndexOrderedListBuilder identity segmentName newNames) + + nameIdxDelta : Int + nameIdxDelta = + nameIdx - Maybe.withDefault 0 saPrevNameIdx + in + Mappings newSources newNames (SegmentAccounting updatedSaPrevCol updatedSaPrevSourceIdx updatedSaPrevSourceLine updatedSaPrevSourceCol (Just nameIdx)) <| + vlqs + ++ vlqPrefix + ++ VLQ.encode + [ genColDelta + , moduleIdxDelta + , sourceLineDelta + , sourceColDelta + , nameIdxDelta + ] + + Nothing -> + Mappings newSources nms updatedSa <| + vlqs + ++ vlqPrefix + ++ VLQ.encode + [ genColDelta + , moduleIdxDelta + , sourceLineDelta + , sourceColDelta + ] + + + +-- Array builder + + +type OrderedListBuilder c k + = OrderedListBuilder Int (Dict c k Int) + + +emptyOrderedListBuilder : OrderedListBuilder c k +emptyOrderedListBuilder = + OrderedListBuilder 0 Dict.empty + + +insertIntoOrderedListBuilder : (k -> comparable) -> k -> OrderedListBuilder comparable k -> OrderedListBuilder comparable k +insertIntoOrderedListBuilder toComparable value ((OrderedListBuilder nextIndex values) as builder) = + case Dict.get toComparable value values of + Just _ -> + builder + + Nothing -> + OrderedListBuilder (nextIndex + 1) (Dict.insert toComparable value nextIndex values) + + +lookupIndexOrderedListBuilder : (k -> comparable) -> k -> OrderedListBuilder comparable k -> Maybe Int +lookupIndexOrderedListBuilder toComparable value (OrderedListBuilder _ values) = + Dict.get toComparable value values + + +orderedListBuilderToList : (k -> k -> Order) -> OrderedListBuilder c k -> List k +orderedListBuilderToList keyComparison (OrderedListBuilder _ values) = + values + |> Dict.toList keyComparison + |> List.map (\( val, idx ) -> ( idx, val )) + |> Dict.fromList identity + |> Dict.values compare + + +mappingsToJson : Dict (List String) IO.Canonical String -> Mappings -> Encode.Value +mappingsToJson moduleSources (Mappings sources names _ vlqs) = + let + moduleNames : List IO.Canonical + moduleNames = + orderedListBuilderToList ModuleName.compareCanonical sources + in + Encode.object + [ ( "version", Encode.int 3 ) + , ( "sources", Encode.list (\(IO.Canonical _ name) -> Encode.string name) moduleNames ) + , ( "sourcesContent" + , Encode.list + (\moduleName -> + Dict.get ModuleName.toComparableCanonical moduleName moduleSources + |> Maybe.map Encode.string + |> Maybe.withDefault Encode.null + ) + moduleNames + ) + , ( "names", Encode.list (\jsName -> Encode.string jsName) (orderedListBuilderToList compare names) ) + , ( "mappings", Encode.string vlqs ) + ] diff --git a/src/Compiler/Generate/Mode.elm b/src/Compiler/Generate/Mode.elm new file mode 100644 index 0000000000..232c17d91f --- /dev/null +++ b/src/Compiler/Generate/Mode.elm @@ -0,0 +1,69 @@ +module Compiler.Generate.Mode exposing + ( Mode(..) + , ShortFieldNames + , isDebug + , shortenFieldNames + ) + +import Compiler.AST.Optimized as Opt +import Compiler.Data.Name as Name +import Compiler.Elm.Compiler.Type.Extract as Extract +import Compiler.Generate.JavaScript.Name as JsName +import Data.Map as Dict exposing (Dict) +import Utils.Main as Utils + + + +-- MODE + + +type Mode + = Dev (Maybe Extract.Types) + | Prod ShortFieldNames + + +isDebug : Mode -> Bool +isDebug mode = + case mode of + Dev (Just _) -> + True + + Dev Nothing -> + False + + Prod _ -> + False + + + +-- SHORTEN FIELD NAMES + + +type alias ShortFieldNames = + Dict String Name.Name JsName.Name + + +shortenFieldNames : Opt.GlobalGraph -> ShortFieldNames +shortenFieldNames (Opt.GlobalGraph _ frequencies) = + Dict.foldr compare (\_ -> addToShortNames) Dict.empty <| + Dict.foldr compare addToBuckets Dict.empty frequencies + + +addToBuckets : Name.Name -> Int -> Dict Int Int (List Name.Name) -> Dict Int Int (List Name.Name) +addToBuckets field frequency buckets = + Utils.mapInsertWith identity (++) frequency [ field ] buckets + + +addToShortNames : List Name.Name -> ShortFieldNames -> ShortFieldNames +addToShortNames fields shortNames = + List.foldl addField shortNames fields + + +addField : Name.Name -> ShortFieldNames -> ShortFieldNames +addField field shortNames = + let + rename : JsName.Name + rename = + JsName.fromInt (Dict.size shortNames) + in + Dict.insert identity field rename shortNames diff --git a/src/Compiler/Json/Decode.elm b/src/Compiler/Json/Decode.elm new file mode 100644 index 0000000000..1afe64024a --- /dev/null +++ b/src/Compiler/Json/Decode.elm @@ -0,0 +1,984 @@ +module Compiler.Json.Decode exposing + ( DecodeExpectation(..) + , Decoder + , Error(..) + , KeyDecoder(..) + , ParseError(..) + , Problem(..) + , StringProblem(..) + , apply + , assocListDict + , bind + , customString + , dict + , everySet + , failure + , field + , fmap + , fromByteString + , int + , jsonPair + , list + , mapError + , nonEmptyList + , nonempty + , oneOf + , oneOrMore + , pair + , pairs + , pure + , result + , string + ) + +import Compiler.Data.NonEmptyList as NE +import Compiler.Data.OneOrMore as OneOrMore exposing (OneOrMore) +import Compiler.Json.String as Json +import Compiler.Parse.Keyword as K +import Compiler.Parse.Primitives as P exposing (Col, Row) +import Compiler.Reporting.Annotation as A +import Data.Map as Dict exposing (Dict) +import Data.Set as EverySet exposing (EverySet) +import Json.Decode as Decode +import Utils.Crash exposing (crash) + + + +-- CORE HELPERS + + +assocListDict : (k -> comparable) -> Decode.Decoder k -> Decode.Decoder v -> Decode.Decoder (Dict comparable k v) +assocListDict toComparable keyDecoder valueDecoder = + Decode.list (jsonPair keyDecoder valueDecoder) + |> Decode.map (Dict.fromList toComparable) + + +jsonPair : Decode.Decoder a -> Decode.Decoder b -> Decode.Decoder ( a, b ) +jsonPair firstDecoder secondDecoder = + Decode.map2 Tuple.pair + (Decode.field "a" firstDecoder) + (Decode.field "b" secondDecoder) + + +everySet : (a -> comparable) -> Decode.Decoder a -> Decode.Decoder (EverySet comparable a) +everySet toComparable decoder = + Decode.list decoder + |> Decode.map (EverySet.fromList toComparable) + + +nonempty : Decode.Decoder a -> Decode.Decoder (NE.Nonempty a) +nonempty decoder = + Decode.list decoder + |> Decode.andThen + (\values -> + case values of + x :: xs -> + Decode.succeed (NE.Nonempty x xs) + + [] -> + Decode.fail "Empty list when it should have at least one element (non-empty list)!" + ) + + +oneOrMore : Decode.Decoder a -> Decode.Decoder (OneOrMore a) +oneOrMore decoder = + Decode.oneOf + [ Decode.map OneOrMore.one (Decode.field "one" decoder) + , Decode.map2 OneOrMore.more + (Decode.field "left" (Decode.lazy (\_ -> oneOrMore decoder))) + (Decode.field "right" (Decode.lazy (\_ -> oneOrMore decoder))) + ] + + +result : Decode.Decoder x -> Decode.Decoder a -> Decode.Decoder (Result x a) +result errDecoder successDecoder = + Decode.field "type" Decode.string + |> Decode.andThen + (\type_ -> + case type_ of + "Err" -> + Decode.map Err (Decode.field "value" errDecoder) + + "Ok" -> + Decode.map Ok (Decode.field "value" successDecoder) + + _ -> + Decode.fail ("Failed to decode result's type: " ++ type_) + ) + + + +-- RUNNERS + + +fromByteString : Decoder x a -> String -> Result (Error x) a +fromByteString (Decoder decode) src = + case P.fromByteString pFile BadEnd src of + Ok ast -> + decode ast + |> Result.mapError (DecodeProblem src) + + Err problem -> + Err (ParseProblem src problem) + + + +-- DECODERS + + +type Decoder x a + = Decoder (AST -> Result (Problem x) a) + + + +-- ERRORS + + +type Error x + = DecodeProblem String (Problem x) + | ParseProblem String ParseError + + + +-- DECODE PROBLEMS + + +type Problem x + = Field String (Problem x) + | Index Int (Problem x) + | OneOf (Problem x) (List (Problem x)) + | Failure A.Region x + | Expecting A.Region DecodeExpectation + + +type DecodeExpectation + = TObject + | TArray + | TString + | TInt + | TObjectWith String + | TArrayPair Int + + + +-- INSTANCES + + +fmap : (a -> b) -> Decoder x a -> Decoder x b +fmap func (Decoder decodeA) = + Decoder (Result.map func << decodeA) + + +pure : a -> Decoder x a +pure a = + Decoder (\_ -> Ok a) + + +apply : Decoder x a -> Decoder x (a -> b) -> Decoder x b +apply (Decoder decodeArg) (Decoder decodeFunc) = + Decoder <| + \ast -> + Result.andThen + (\a -> + Result.map (\b -> a |> b) + (decodeFunc ast) + ) + (decodeArg ast) + + +bind : (a -> Decoder x b) -> Decoder x a -> Decoder x b +bind callback (Decoder decodeA) = + Decoder <| + \ast -> + Result.andThen + (\a -> + case callback a of + Decoder decodeB -> + decodeB ast + ) + (decodeA ast) + + + +-- STRINGS + + +string : Decoder x String +string = + Decoder <| + \(A.At region ast) -> + case ast of + String snippet -> + Ok (Json.fromSnippet snippet) + + _ -> + Err (Expecting region TString) + + +customString : P.Parser x a -> (Row -> Col -> x) -> Decoder x a +customString parser toBadEnd = + Decoder <| + \(A.At region ast) -> + case ast of + String snippet -> + P.fromSnippet parser toBadEnd snippet + |> Result.mapError (Failure region) + + _ -> + Err (Expecting region TString) + + + +-- INT + + +int : Decoder x Int +int = + Decoder <| + \(A.At region ast) -> + case ast of + Int n -> + Ok n + + _ -> + Err (Expecting region TInt) + + + +-- LISTS + + +list : Decoder x a -> Decoder x (List a) +list decoder = + Decoder <| + \(A.At region ast) -> + case ast of + Array asts -> + listHelp decoder 0 asts [] + + _ -> + Err (Expecting region TArray) + + +listHelp : Decoder x a -> Int -> List AST -> List a -> Result (Problem x) (List a) +listHelp ((Decoder decodeA) as decoder) i asts revs = + case asts of + [] -> + Ok (List.reverse revs) + + ast :: asts_ -> + case decodeA ast of + Ok value -> + listHelp decoder (i + 1) asts_ (value :: revs) + + Err prob -> + Err (Index i prob) + + + +-- NON-EMPTY LISTS + + +nonEmptyList : Decoder x a -> x -> Decoder x (NE.Nonempty a) +nonEmptyList decoder x = + Decoder <| + \((A.At region _) as ast) -> + let + (Decoder values) = + list decoder + in + case values ast of + Ok (v :: vs) -> + Ok (NE.Nonempty v vs) + + Ok [] -> + Err (Failure region x) + + Err err -> + Err err + + + +-- PAIR + + +pair : Decoder x a -> Decoder x b -> Decoder x ( a, b ) +pair (Decoder decodeA) (Decoder decodeB) = + Decoder <| + \(A.At region ast) -> + case ast of + Array vs -> + case vs of + [ astA, astB ] -> + Result.andThen + (\a -> + Result.map (Tuple.pair a) (decodeB astB) + ) + (decodeA astA) + + _ -> + Err (Expecting region (TArrayPair (List.length vs))) + + _ -> + Err (Expecting region TArray) + + + +-- OBJECTS + + +type KeyDecoder x a + = KeyDecoder (P.Parser x a) (Row -> Col -> x) + + +dict : (k -> comparable) -> KeyDecoder x k -> Decoder x a -> Decoder x (Dict comparable k a) +dict toComparable keyDecoder valueDecoder = + fmap (Dict.fromList toComparable) (pairs keyDecoder valueDecoder) + + +pairs : KeyDecoder x k -> Decoder x a -> Decoder x (List ( k, a )) +pairs keyDecoder valueDecoder = + Decoder <| + \(A.At region ast) -> + case ast of + Object kvs -> + pairsHelp keyDecoder valueDecoder kvs [] + + _ -> + Err (Expecting region TObject) + + +pairsHelp : KeyDecoder x k -> Decoder x a -> List ( P.Snippet, AST ) -> List ( k, a ) -> Result (Problem x) (List ( k, a )) +pairsHelp ((KeyDecoder keyParser toBadEnd) as keyDecoder) ((Decoder decodeA) as valueDecoder) kvs revs = + case kvs of + [] -> + Ok (List.reverse revs) + + ( snippet, ast ) :: kvs_ -> + case P.fromSnippet keyParser toBadEnd snippet of + Err x -> + Err (Failure (snippetToRegion snippet) x) + + Ok key -> + case decodeA ast of + Ok value -> + pairsHelp keyDecoder valueDecoder kvs_ (( key, value ) :: revs) + + Err prob -> + let + (P.Snippet { fptr, offset, length }) = + snippet + in + Err (Field (String.slice offset (offset + length) fptr) prob) + + +snippetToRegion : P.Snippet -> A.Region +snippetToRegion (P.Snippet { length, offRow, offCol }) = + A.Region (A.Position offRow offCol) (A.Position offRow (offCol + length)) + + + +-- FIELDS + + +field : String -> Decoder x a -> Decoder x a +field key (Decoder decodeA) = + Decoder <| + \(A.At region ast) -> + case ast of + Object kvs -> + case findField key kvs of + Just value -> + Result.mapError (Field key) + (decodeA value) + + Nothing -> + Err (Expecting region (TObjectWith key)) + + _ -> + Err (Expecting region TObject) + + +findField : String -> List ( P.Snippet, AST ) -> Maybe AST +findField key pairs_ = + case pairs_ of + [] -> + Nothing + + ( P.Snippet { fptr, offset, length }, value ) :: remainingPairs -> + if key == String.slice offset (offset + length) fptr then + Just value + + else + findField key remainingPairs + + + +-- ONE OF + + +oneOf : List (Decoder x a) -> Decoder x a +oneOf decoders = + Decoder <| + \ast -> + case decoders of + (Decoder decodeA) :: decoders_ -> + case decodeA ast of + Ok a -> + Ok a + + Err e -> + oneOfHelp ast decoders_ [] e + + [] -> + crash "Ran into (Json.Decode.oneOf [])" + + +oneOfHelp : AST -> List (Decoder x a) -> List (Problem x) -> Problem x -> Result (Problem x) a +oneOfHelp ast decoders ps p = + case decoders of + (Decoder decodeA) :: decoders_ -> + case decodeA ast of + Ok a -> + Ok a + + Err p_ -> + oneOfHelp ast decoders_ (p :: ps) p_ + + [] -> + Err (oneOfError [] p ps) + + +oneOfError : List (Problem x) -> Problem x -> List (Problem x) -> Problem x +oneOfError problems prob ps = + case ps of + [] -> + OneOf prob problems + + p :: ps_ -> + oneOfError (prob :: problems) p ps_ + + + +-- FAILURE + + +failure : x -> Decoder x a +failure x = + Decoder <| + \(A.At region _) -> + Err (Failure region x) + + + +-- ERRORS + + +mapError : (x -> y) -> Decoder x a -> Decoder y a +mapError func (Decoder decodeA) = + Decoder (Result.mapError (mapErrorHelp func) << decodeA) + + +mapErrorHelp : (x -> y) -> Problem x -> Problem y +mapErrorHelp func problem = + case problem of + Field k p -> + Field k (mapErrorHelp func p) + + Index i p -> + Index i (mapErrorHelp func p) + + OneOf p ps -> + OneOf (mapErrorHelp func p) (List.map (mapErrorHelp func) ps) + + Failure r x -> + Failure r (func x) + + Expecting r e -> + Expecting r e + + + +-- AST + + +type alias AST = + A.Located AST_ + + +type AST_ + = Array (List AST) + | Object (List ( P.Snippet, AST )) + | String P.Snippet + | Int Int + | TRUE + | FALSE + | NULL + + + +-- PARSE + + +type alias Parser a = + P.Parser ParseError a + + +type ParseError + = Start Row Col + | ObjectField Row Col + | ObjectColon Row Col + | ObjectEnd Row Col + | ArrayEnd Row Col + | StringProblem StringProblem Row Col + | NoLeadingZeros Row Col + | NoFloats Row Col + | BadEnd Row Col + + +type StringProblem + = BadStringEnd + | BadStringControlChar + | BadStringEscapeChar + | BadStringEscapeHex + + + +-- PARSE AST + + +pFile : Parser AST +pFile = + spaces + |> P.bind (\_ -> pValue) + |> P.bind + (\value -> + P.fmap (\_ -> value) spaces + ) + + +pValue : Parser AST +pValue = + P.addLocation <| + P.oneOf Start + [ P.fmap String (pString Start) + , pObject + , pArray + , pInt + , P.fmap (\_ -> TRUE) (K.k4 't' 'r' 'u' 'e' Start) + , P.fmap (\_ -> FALSE) (K.k5 'f' 'a' 'l' 's' 'e' Start) + , P.fmap (\_ -> NULL) (K.k4 'n' 'u' 'l' 'l' Start) + ] + + + +-- OBJECT + + +pObject : Parser AST_ +pObject = + P.word1 '{' Start + |> P.bind (\_ -> spaces) + |> P.bind + (\_ -> + P.oneOf ObjectField + [ pField + |> P.bind + (\entry -> + spaces + |> P.bind (\_ -> P.loop pObjectHelp [ entry ]) + ) + , P.word1 '}' ObjectEnd + |> P.fmap (\_ -> Object []) + ] + ) + + +pObjectHelp : List ( P.Snippet, AST ) -> Parser (P.Step (List ( P.Snippet, AST )) AST_) +pObjectHelp revEntries = + P.oneOf ObjectEnd + [ P.word1 ',' ObjectEnd + |> P.bind (\_ -> spaces) + |> P.bind (\_ -> pField) + |> P.bind + (\entry -> + spaces + |> P.fmap (\_ -> P.Loop (entry :: revEntries)) + ) + , P.word1 '}' ObjectEnd + |> P.fmap (\_ -> P.Done (Object (List.reverse revEntries))) + ] + + +pField : Parser ( P.Snippet, AST ) +pField = + pString ObjectField + |> P.bind + (\key -> + spaces + |> P.bind (\_ -> P.word1 ':' ObjectColon) + |> P.bind (\_ -> spaces) + |> P.bind (\_ -> pValue) + |> P.fmap (\value -> ( key, value )) + ) + + + +-- ARRAY + + +pArray : Parser AST_ +pArray = + P.word1 '[' Start + |> P.bind (\_ -> spaces) + |> P.bind + (\_ -> + P.oneOf Start + [ pValue + |> P.bind + (\entry -> + spaces + |> P.bind (\_ -> pArrayHelp [ entry ]) + ) + , P.word1 ']' ArrayEnd + |> P.fmap (\_ -> Array []) + ] + ) + + +pArrayHelp : List AST -> Parser AST_ +pArrayHelp revEntries = + P.oneOf ArrayEnd + [ P.word1 ',' ArrayEnd + |> P.bind (\_ -> spaces) + |> P.bind (\_ -> pValue) + |> P.bind + (\entry -> + spaces + |> P.bind (\_ -> pArrayHelp (entry :: revEntries)) + ) + , P.word1 ']' ArrayEnd + |> P.fmap (\_ -> Array (List.reverse revEntries)) + ] + + + +-- STRING + + +pString : (Row -> Col -> ParseError) -> Parser P.Snippet +pString start = + P.Parser <| + \(P.State src pos end indent row col) -> + if pos < end && P.unsafeIndex src pos == '"' then + let + pos1 : Int + pos1 = + pos + 1 + + col1 : Col + col1 = + col + 1 + + ( ( status, newPos ), ( newRow, newCol ) ) = + pStringHelp src pos1 end row col1 + in + case status of + GoodString -> + let + off : Int + off = + -- FIXME pos1 - unsafeForeignPtrToPtr src + pos1 + + len : Int + len = + (newPos - pos1) - 1 + + snp : P.Snippet + snp = + P.Snippet + { fptr = src + , offset = off + , length = len + , offRow = row + , offCol = col1 + } + + newState : P.State + newState = + P.State src newPos end indent newRow newCol + in + P.Cok snp newState + + BadString problem -> + P.Cerr newRow newCol (StringProblem problem) + + else + P.Eerr row col start + + +type StringStatus + = GoodString + | BadString StringProblem + + +pStringHelp : String -> Int -> Int -> Row -> Col -> ( ( StringStatus, Int ), ( Row, Col ) ) +pStringHelp src pos end row col = + if pos >= end then + ( ( BadString BadStringEnd, pos ), ( row, col ) ) + + else + case P.unsafeIndex src pos of + '"' -> + ( ( GoodString, pos + 1 ), ( row, col + 1 ) ) + + '\n' -> + ( ( BadString BadStringEnd, pos ), ( row, col ) ) + + '\\' -> + let + pos1 : Int + pos1 = + pos + 1 + in + if pos1 >= end then + ( ( BadString BadStringEnd, pos1 ), ( row + 1, col ) ) + + else + case P.unsafeIndex src pos1 of + '"' -> + pStringHelp src (pos + 2) end row (col + 2) + + '\\' -> + pStringHelp src (pos + 2) end row (col + 2) + + '/' -> + pStringHelp src (pos + 2) end row (col + 2) + + 'b' -> + pStringHelp src (pos + 2) end row (col + 2) + + {- f -} + 'f' -> + pStringHelp src (pos + 2) end row (col + 2) + + {- n -} + 'n' -> + pStringHelp src (pos + 2) end row (col + 2) + + {- r -} + 'r' -> + pStringHelp src (pos + 2) end row (col + 2) + + {- t -} + 't' -> + pStringHelp src (pos + 2) end row (col + 2) + + {- u -} + 'u' -> + let + pos6 : Int + pos6 = + pos + 6 + in + if + (pos6 <= end) + && isHex (P.unsafeIndex src (pos + 2)) + && isHex (P.unsafeIndex src (pos + 3)) + && isHex (P.unsafeIndex src (pos + 4)) + && isHex (P.unsafeIndex src (pos + 5)) + then + pStringHelp src pos6 end row (col + 6) + + else + ( ( BadString BadStringEscapeHex, pos ), ( row, col ) ) + + _ -> + ( ( BadString BadStringEscapeChar, pos ), ( row, col ) ) + + word -> + if Char.toCode word < 0x20 then + ( ( BadString BadStringControlChar, pos ), ( row, col ) ) + + else + let + newPos : Int + newPos = + pos + P.getCharWidth word + in + pStringHelp src newPos end row (col + 1) + + +isHex : Char -> Bool +isHex word = + let + code : Int + code = + Char.toCode word + in + (0x30 {- 0 -} <= code) + && (code <= 0x39 {- 9 -}) + || (0x61 {- a -} <= code) + && (code <= 0x66 {- f -}) + || (0x41 {- A -} <= code) + && (code <= 0x46 {- F -}) + + + +-- SPACES + + +spaces : Parser () +spaces = + P.Parser <| + \((P.State src pos end indent row col) as state) -> + let + ( newPos, newRow, newCol ) = + eatSpaces src pos end row col + in + if pos == newPos then + P.Eok () state + + else + let + newState : P.State + newState = + P.State src newPos end indent newRow newCol + in + P.Cok () newState + + +eatSpaces : String -> Int -> Int -> Row -> Col -> ( Int, Row, Col ) +eatSpaces src pos end row col = + if pos >= end then + ( pos, row, col ) + + else + case P.unsafeIndex src pos of + ' ' -> + eatSpaces src (pos + 1) end row (col + 1) + + '\t' -> + eatSpaces src (pos + 1) end row (col + 1) + + '\n' -> + eatSpaces src (pos + 1) end (row + 1) 1 + + {- \r -} + '\u{000D}' -> + eatSpaces src (pos + 1) end row col + + _ -> + ( pos, row, col ) + + + +-- INTS + + +pInt : Parser AST_ +pInt = + P.Parser <| + \(P.State src pos end indent row col) -> + if pos >= end then + P.Eerr row col Start + + else + let + word : Char + word = + P.unsafeIndex src pos + in + if not (isDecimalDigit word) then + P.Eerr row col Start + + else if word == '0' then + let + pos1 : Int + pos1 = + pos + 1 + + newState : P.State + newState = + P.State src pos1 end indent row (col + 1) + in + if pos1 < end then + let + word1 : Char + word1 = + P.unsafeIndex src pos1 + in + if isDecimalDigit word1 then + P.Cerr row (col + 1) NoLeadingZeros + + else if word1 == '.' then + P.Cerr row (col + 1) NoFloats + + else + P.Cok (Int 0) newState + + else + P.Cok (Int 0) newState + + else + let + ( status, n, newPos ) = + chompInt src (pos + 1) end (Char.toCode word - 0x30 {- 0 -}) + + len : Int + len = + newPos - pos + in + case status of + GoodInt -> + let + newState : P.State + newState = + P.State src newPos end indent row (col + len) + in + P.Cok (Int n) newState + + BadIntEnd -> + P.Cerr row (col + len) NoFloats + + +type IntStatus + = GoodInt + | BadIntEnd + + +chompInt : String -> Int -> Int -> Int -> ( IntStatus, Int, Int ) +chompInt src pos end n = + if pos < end then + let + word : Char + word = + P.unsafeIndex src pos + in + if isDecimalDigit word then + let + m : Int + m = + 10 * n + (Char.toCode word - 0x30 {- 0 -}) + in + chompInt src (pos + 1) end m + + else if word == '.' || word == 'e' || word == 'E' then + ( BadIntEnd, n, pos ) + + else + ( GoodInt, n, pos ) + + else + ( GoodInt, n, pos ) + + +isDecimalDigit : Char -> Bool +isDecimalDigit word = + let + code : Int + code = + Char.toCode word + in + code <= 0x39 {- 9 -} && code >= {- 0 -} 0x30 diff --git a/src/Compiler/Json/Encode.elm b/src/Compiler/Json/Encode.elm new file mode 100644 index 0000000000..08d1a2bffa --- /dev/null +++ b/src/Compiler/Json/Encode.elm @@ -0,0 +1,386 @@ +module Compiler.Json.Encode exposing + ( Value(..) + , array + , assocListDict + , bool + , chars + , dict + , encodeUgly + , everySet + , int + , jsonPair + , list + , maybe + , name + , nonempty + , null + , number + , object + , oneOrMore + , result + , string + , toJsonValue + , write + , writeUgly + ) + +import Compiler.Data.NonEmptyList as NE +import Compiler.Data.OneOrMore exposing (OneOrMore(..)) +import Data.Map as Dict exposing (Dict) +import Data.Set as EverySet exposing (EverySet) +import Json.Encode as Encode +import System.IO as IO +import Task exposing (Task) + + + +-- CORE HELPERS + + +assocListDict : (k -> k -> Order) -> (k -> Encode.Value) -> (v -> Encode.Value) -> Dict c k v -> Encode.Value +assocListDict keyComparison keyEncoder valueEncoder = + Encode.list (jsonPair keyEncoder valueEncoder) << List.reverse << Dict.toList keyComparison + + +jsonPair : (a -> Encode.Value) -> (b -> Encode.Value) -> ( a, b ) -> Encode.Value +jsonPair firstEncoder secondEncoder ( a, b ) = + Encode.object + [ ( "a", firstEncoder a ) + , ( "b", secondEncoder b ) + ] + + +everySet : (a -> a -> Order) -> (a -> Encode.Value) -> EverySet c a -> Encode.Value +everySet keyComparison encoder = + Encode.list encoder << List.reverse << EverySet.toList keyComparison + + +result : (x -> Encode.Value) -> (a -> Encode.Value) -> Result x a -> Encode.Value +result errEncoder successEncoder resultValue = + case resultValue of + Ok value -> + Encode.object + [ ( "type", Encode.string "Ok" ) + , ( "value", successEncoder value ) + ] + + Err err -> + Encode.object + [ ( "type", Encode.string "Err" ) + , ( "value", errEncoder err ) + ] + + +maybe : (a -> Encode.Value) -> Maybe a -> Encode.Value +maybe encoder maybeValue = + case maybeValue of + Just value -> + encoder value + + Nothing -> + Encode.null + + +nonempty : (a -> Encode.Value) -> NE.Nonempty a -> Encode.Value +nonempty encoder (NE.Nonempty x xs) = + Encode.list encoder (x :: xs) + + +oneOrMore : (a -> Encode.Value) -> OneOrMore a -> Encode.Value +oneOrMore encoder oneOrMore_ = + case oneOrMore_ of + One value -> + Encode.object [ ( "one", encoder value ) ] + + More left right -> + Encode.object + [ ( "left", oneOrMore encoder left ) + , ( "right", oneOrMore encoder right ) + ] + + + +-- VALUES + + +type Value + = Array (List Value) + | Object (List ( String, Value )) + | StringVal String + | Boolean Bool + | Integer Int + | Number Float + | Null + + +array : List Value -> Value +array = + Array + + +object : List ( String, Value ) -> Value +object = + Object + + +string : String -> Value +string str = + StringVal (escape str) + + +name : String -> Value +name nm = + StringVal nm + + +bool : Bool -> Value +bool = + Boolean + + +int : Int -> Value +int = + Integer + + +number : Float -> Value +number = + Number + + +null : Value +null = + Null + + +dict : (k -> k -> Order) -> (k -> String) -> (v -> Value) -> Dict c k v -> Value +dict keyComparison encodeKey encodeValue pairs = + Object + (Dict.toList keyComparison pairs + |> List.map (\( k, v ) -> ( encodeKey k, encodeValue v )) + ) + + +list : (a -> Value) -> List a -> Value +list encodeEntry entries = + Array (List.map encodeEntry entries) + + + +-- CHARS + + +chars : String -> Value +chars chrs = + StringVal (escape chrs) + + +escape : String -> String +escape chrs = + String.toList chrs + |> List.map + (\c -> + case c of + '\u{000D}' -> + "\\r" + + '\n' -> + "\\n" + + '"' -> + "\\\"" + + '\\' -> + "\\\\" + + _ -> + String.fromChar c + ) + |> String.concat + + + +-- WRITE TO FILE + + +write : String -> Value -> Task Never () +write path value = + fileWriteBuilder path (encode value ++ "\n") + + +writeUgly : String -> Value -> Task Never () +writeUgly path value = + fileWriteBuilder path (encodeUgly value) + + +{-| FIXME Builder.File.writeBuilder +-} +fileWriteBuilder : String -> String -> Task Never () +fileWriteBuilder = + IO.writeString + + + +-- ENCODE UGLY + + +encodeUgly : Value -> String +encodeUgly value = + case value of + Array [] -> + "[]" + + Array entries -> + "[" ++ String.join "," (List.map encodeUgly entries) ++ "]" + + Object [] -> + "{}" + + Object entries -> + "{" ++ String.join "," (List.map encodeEntryUgly entries) ++ "}" + + StringVal builder -> + "\"" ++ builder ++ "\"" + + Boolean boolean -> + if boolean then + "true" + + else + "false" + + Integer n -> + String.fromInt n + + Number scientific -> + String.fromFloat scientific + + Null -> + "null" + + +encodeEntryUgly : ( String, Value ) -> String +encodeEntryUgly ( key, entry ) = + "\"" ++ key ++ "\":" ++ encodeUgly entry + + + +-- ENCODE + + +encode : Value -> String +encode value = + encodeHelp "" value + + +encodeHelp : String -> Value -> String +encodeHelp indent value = + case value of + Array [] -> + "[]" + + Array (first :: rest) -> + encodeArray indent first rest + + Object [] -> + "{}" + + Object (first :: rest) -> + encodeObject indent first rest + + StringVal builder -> + "\"" ++ builder ++ "\"" + + Boolean boolean -> + if boolean then + "true" + + else + "false" + + Integer n -> + String.fromInt n + + Number scientific -> + String.fromFloat scientific + + Null -> + "null" + + + +-- ENCODE ARRAY + + +encodeArray : String -> Value -> List Value -> String +encodeArray indent first rest = + let + newIndent : String + newIndent = + indent ++ " " + + closer : String + closer = + "\n" ++ indent ++ "]" + + addValue : Value -> String -> String + addValue field builder = + ",\n" ++ newIndent ++ encodeHelp newIndent field ++ builder + in + "[\n" ++ newIndent ++ encodeHelp newIndent first ++ List.foldr addValue closer rest + + + +-- ENCODE OBJECT + + +encodeObject : String -> ( String, Value ) -> List ( String, Value ) -> String +encodeObject indent first rest = + let + newIndent : String + newIndent = + indent ++ " " + + closer : String + closer = + "\n" ++ indent ++ "}" + + addValue : ( String, Value ) -> String -> String + addValue field builder = + ",\n" ++ newIndent ++ encodeField newIndent field ++ builder + in + "{\n" ++ newIndent ++ encodeField newIndent first ++ List.foldr addValue closer rest + + +encodeField : String -> ( String, Value ) -> String +encodeField indent ( key, value ) = + "\"" ++ key ++ "\": " ++ encodeHelp indent value + + + +-- JSON VALUE + + +toJsonValue : Value -> Encode.Value +toJsonValue value = + case value of + Array arr -> + Encode.list toJsonValue arr + + Object obj -> + Encode.object (List.map (Tuple.mapSecond toJsonValue) obj) + + StringVal builder -> + Encode.string builder + + Boolean boolean -> + Encode.bool boolean + + Integer n -> + Encode.int n + + Number scientific -> + Encode.float scientific + + Null -> + Encode.null diff --git a/src/Compiler/Json/String.elm b/src/Compiler/Json/String.elm new file mode 100644 index 0000000000..7f8bf2a446 --- /dev/null +++ b/src/Compiler/Json/String.elm @@ -0,0 +1,148 @@ +module Compiler.Json.String exposing + ( fromComment + , fromName + , fromSnippet + , isEmpty + ) + +import Compiler.Data.Name as Name +import Compiler.Parse.Primitives as P + + + +-- JSON STRINGS + + +isEmpty : String -> Bool +isEmpty = + String.isEmpty + + + +-- FROM + + +fromSnippet : P.Snippet -> String +fromSnippet (P.Snippet { fptr, offset, length }) = + String.slice offset (offset + length) fptr + + +fromName : Name.Name -> String +fromName = + identity + + + +-- FROM COMMENT + + +fromComment : P.Snippet -> String +fromComment ((P.Snippet { fptr, offset, length }) as snippet) = + let + pos : Int + pos = + offset + + end : Int + end = + pos + length + in + fromChunks snippet (chompChunks fptr pos end pos []) + + +chompChunks : String -> Int -> Int -> Int -> List Chunk -> List Chunk +chompChunks src pos end start revChunks = + if pos >= end then + List.reverse (addSlice start end revChunks) + + else + let + word : Char + word = + P.unsafeIndex src pos + in + case word of + '\n' -> + chompChunks src (pos + 1) end (pos + 1) (Escape 'n' :: addSlice start pos revChunks) + + '"' -> + chompChunks src (pos + 1) end (pos + 1) (Escape '"' :: addSlice start pos revChunks) + + '\\' -> + chompChunks src (pos + 1) end (pos + 1) (Escape '\\' :: addSlice start pos revChunks) + + {- \r -} + '\u{000D}' -> + let + newPos : Int + newPos = + pos + 1 + in + chompChunks src newPos end newPos (addSlice start pos revChunks) + + _ -> + let + width : Int + width = + P.getCharWidth word + + newPos : Int + newPos = + pos + width + in + chompChunks src newPos end start revChunks + + +addSlice : Int -> Int -> List Chunk -> List Chunk +addSlice start end revChunks = + if start == end then + revChunks + + else + Slice start (end - start) :: revChunks + + + +-- FROM CHUNKS + + +type Chunk + = Slice Int Int + | Escape Char + + +fromChunks : P.Snippet -> List Chunk -> String +fromChunks snippet chunks = + writeChunks snippet chunks + + +writeChunks : P.Snippet -> List Chunk -> String +writeChunks snippet chunks = + writeChunksHelp snippet chunks "" + + +writeChunksHelp : P.Snippet -> List Chunk -> String -> String +writeChunksHelp ((P.Snippet { fptr }) as snippet) chunks acc = + case chunks of + [] -> + acc + + chunk :: chunks_ -> + writeChunksHelp snippet + chunks_ + (case chunk of + Slice offset len -> + acc ++ String.slice offset (offset + len) fptr + + Escape 'n' -> + acc ++ String.fromChar '\n' + + Escape '"' -> + acc ++ String.fromChar '"' + + Escape '\\' -> + acc ++ String.fromChar '\\' + + Escape word -> + acc ++ String.fromList [ '\\', word ] + ) diff --git a/src/Compiler/Nitpick/Debug.elm b/src/Compiler/Nitpick/Debug.elm new file mode 100644 index 0000000000..066ebc8b1f --- /dev/null +++ b/src/Compiler/Nitpick/Debug.elm @@ -0,0 +1,175 @@ +module Compiler.Nitpick.Debug exposing (hasDebugUses) + +import Compiler.AST.Optimized as Opt +import Compiler.Data.Map.Utils as Map +import Compiler.Reporting.Annotation as A +import Data.Map as Dict + + + +-- HAS DEBUG USES + + +hasDebugUses : Opt.LocalGraph -> Bool +hasDebugUses (Opt.LocalGraph _ graph _) = + Map.any nodeHasDebug graph + + +nodeHasDebug : Opt.Node -> Bool +nodeHasDebug node = + case node of + Opt.Define expr _ -> + hasDebug expr + + Opt.TrackedDefine _ expr _ -> + hasDebug expr + + Opt.DefineTailFunc _ _ expr _ -> + hasDebug expr + + Opt.Ctor _ _ -> + False + + Opt.Enum _ -> + False + + Opt.Box -> + False + + Opt.Link _ -> + False + + Opt.Cycle _ vs fs _ -> + List.any (hasDebug << Tuple.second) vs || List.any defHasDebug fs + + Opt.Manager _ -> + False + + Opt.Kernel _ _ -> + False + + Opt.PortIncoming expr _ -> + hasDebug expr + + Opt.PortOutgoing expr _ -> + hasDebug expr + + +hasDebug : Opt.Expr -> Bool +hasDebug expression = + case expression of + Opt.Bool _ _ -> + False + + Opt.Chr _ _ -> + False + + Opt.Str _ _ -> + False + + Opt.Int _ _ -> + False + + Opt.Float _ _ -> + False + + Opt.VarLocal _ -> + False + + Opt.TrackedVarLocal _ _ -> + False + + Opt.VarGlobal _ _ -> + False + + Opt.VarEnum _ _ _ -> + False + + Opt.VarBox _ _ -> + False + + Opt.VarCycle _ _ _ -> + False + + Opt.VarDebug _ _ _ _ -> + True + + Opt.VarKernel _ _ _ -> + False + + Opt.List _ exprs -> + List.any hasDebug exprs + + Opt.Function _ expr -> + hasDebug expr + + Opt.TrackedFunction _ expr -> + hasDebug expr + + Opt.Call _ e es -> + hasDebug e || List.any hasDebug es + + Opt.TailCall _ args -> + List.any (hasDebug << Tuple.second) args + + Opt.If conds finally -> + List.any (\( c, e ) -> hasDebug c || hasDebug e) conds || hasDebug finally + + Opt.Let def body -> + defHasDebug def || hasDebug body + + Opt.Destruct _ expr -> + hasDebug expr + + Opt.Case _ _ d jumps -> + deciderHasDebug d || List.any (hasDebug << Tuple.second) jumps + + Opt.Accessor _ _ -> + False + + Opt.Access r _ _ -> + hasDebug r + + Opt.Update _ r fs -> + hasDebug r || List.any hasDebug (Dict.values A.compareLocated fs) + + Opt.Record fs -> + List.any hasDebug (Dict.values compare fs) + + Opt.TrackedRecord _ fs -> + List.any hasDebug (Dict.values A.compareLocated fs) + + Opt.Unit -> + False + + Opt.Tuple _ a b cs -> + hasDebug a || hasDebug b || List.any hasDebug cs + + Opt.Shader _ _ _ -> + False + + +defHasDebug : Opt.Def -> Bool +defHasDebug def = + case def of + Opt.Def _ _ expr -> + hasDebug expr + + Opt.TailDef _ _ _ expr -> + hasDebug expr + + +deciderHasDebug : Opt.Decider Opt.Choice -> Bool +deciderHasDebug decider = + case decider of + Opt.Leaf (Opt.Inline expr) -> + hasDebug expr + + Opt.Leaf (Opt.Jump _) -> + False + + Opt.Chain _ success failure -> + deciderHasDebug success || deciderHasDebug failure + + Opt.FanOut _ tests fallback -> + List.any (deciderHasDebug << Tuple.second) tests || deciderHasDebug fallback diff --git a/src/Compiler/Nitpick/PatternMatches.elm b/src/Compiler/Nitpick/PatternMatches.elm new file mode 100644 index 0000000000..8c470a558e --- /dev/null +++ b/src/Compiler/Nitpick/PatternMatches.elm @@ -0,0 +1,888 @@ +module Compiler.Nitpick.PatternMatches exposing + ( Context(..) + , Error(..) + , Literal(..) + , Pattern(..) + , check + , errorDecoder + , errorEncoder + ) + +{- The algorithm used here comes from "Warnings for Pattern Matching" + by Luc Maranget. Check it out for more information! + + http://moscova.inria.fr/~maranget/papers/warn/warn.pdf + +-} + +import Compiler.AST.Canonical as Can +import Compiler.Data.Index as Index +import Compiler.Data.Name as Name +import Compiler.Data.NonEmptyList as NE +import Compiler.Elm.ModuleName as ModuleName +import Compiler.Reporting.Annotation as A +import Data.Map as Dict exposing (Dict) +import List.Extra as List +import Prelude +import Utils.Bytes.Decode as BD +import Utils.Bytes.Encode as BE +import Utils.Crash exposing (crash) +import Utils.Main as Utils + + + +-- PATTERN + + +type Pattern + = Anything + | Literal Literal + | Ctor Can.Union Name.Name (List Pattern) + + +type Literal + = Chr String + | Str String + | Int Int + + + +-- CREATE SIMPLIFIED PATTERNS + + +simplify : Can.Pattern -> Pattern +simplify (A.At _ pattern) = + case pattern of + Can.PAnything -> + Anything + + Can.PVar _ -> + Anything + + Can.PRecord _ -> + Anything + + Can.PUnit -> + Ctor unit unitName [] + + Can.PTuple a b [] -> + Ctor pair pairName [ simplify a, simplify b ] + + Can.PTuple a b [ c ] -> + Ctor triple tripleName [ simplify a, simplify b, simplify c ] + + Can.PTuple a b cs -> + Ctor nTuple nTupleName (List.map simplify (a :: b :: cs)) + + Can.PCtor { union, name, args } -> + Ctor union name <| + List.map (\(Can.PatternCtorArg _ _ arg) -> simplify arg) args + + Can.PList entries -> + List.foldr cons nil entries + + Can.PCons hd tl -> + cons hd (simplify tl) + + Can.PAlias subPattern _ -> + simplify subPattern + + Can.PInt int -> + Literal (Int int) + + Can.PStr str _ -> + Literal (Str str) + + Can.PChr chr -> + Literal (Chr chr) + + Can.PBool union bool -> + Ctor union + (if bool then + Name.true + + else + Name.false + ) + [] + + +cons : Can.Pattern -> Pattern -> Pattern +cons hd tl = + Ctor list consName [ simplify hd, tl ] + + +nil : Pattern +nil = + Ctor list nilName [] + + + +-- BUILT-IN UNIONS + + +unit : Can.Union +unit = + let + ctor : Can.Ctor + ctor = + Can.Ctor unitName Index.first 0 [] + in + Can.Union [] [ ctor ] 1 Can.Normal + + +pair : Can.Union +pair = + let + ctor : Can.Ctor + ctor = + Can.Ctor pairName Index.first 2 [ Can.TVar "a", Can.TVar "b" ] + in + Can.Union [ "a", "b" ] [ ctor ] 1 Can.Normal + + +triple : Can.Union +triple = + let + ctor : Can.Ctor + ctor = + Can.Ctor tripleName Index.first 3 [ Can.TVar "a", Can.TVar "b", Can.TVar "c" ] + in + Can.Union [ "a", "b", "c" ] [ ctor ] 1 Can.Normal + + +nTuple : Can.Union +nTuple = + let + ctor : Can.Ctor + ctor = + Can.Ctor nTupleName Index.first 3 [ Can.TVar "a", Can.TVar "b", Can.TVar "cs" ] + in + Can.Union [ "a", "b", "cs" ] [ ctor ] 1 Can.Normal + + +list : Can.Union +list = + let + nilCtor : Can.Ctor + nilCtor = + Can.Ctor nilName Index.first 0 [] + + consCtor : Can.Ctor + consCtor = + Can.Ctor consName + Index.second + 2 + [ Can.TVar "a" + , Can.TType ModuleName.list Name.list [ Can.TVar "a" ] + ] + in + Can.Union [ "a" ] [ nilCtor, consCtor ] 2 Can.Normal + + +unitName : Name.Name +unitName = + "#0" + + +pairName : Name.Name +pairName = + "#2" + + +tripleName : Name.Name +tripleName = + "#3" + + +nTupleName : Name.Name +nTupleName = + "#N" + + +consName : Name.Name +consName = + "::" + + +nilName : Name.Name +nilName = + "[]" + + + +-- ERROR + + +type Error + = Incomplete A.Region Context (List Pattern) + | Redundant A.Region A.Region Int + + +type Context + = BadArg + | BadDestruct + | BadCase + + + +-- CHECK + + +check : Can.Module -> Result (NE.Nonempty Error) () +check (Can.Module _ _ _ decls _ _ _ _) = + case checkDecls decls [] identity of + [] -> + Ok () + + e :: es -> + Err (NE.Nonempty e es) + + + +-- CHECK DECLS + + +checkDecls : Can.Decls -> List Error -> (List Error -> List Error) -> List Error +checkDecls decls errors cont = + case decls of + Can.Declare def subDecls -> + checkDecls subDecls errors (checkDef def >> cont) + + Can.DeclareRec def defs subDecls -> + List.foldr checkDef (checkDecls subDecls errors (checkDef def >> cont)) defs + + Can.SaveTheEnvironment -> + cont errors + + + +-- CHECK DEFS + + +checkDef : Can.Def -> List Error -> List Error +checkDef def errors = + case def of + Can.Def _ args body -> + List.foldr checkArg (checkExpr body errors) args + + Can.TypedDef _ _ args body _ -> + List.foldr checkTypedArg (checkExpr body errors) args + + +checkArg : Can.Pattern -> List Error -> List Error +checkArg ((A.At region _) as pattern) errors = + checkPatterns region BadArg [ pattern ] errors + + +checkTypedArg : ( Can.Pattern, tipe ) -> List Error -> List Error +checkTypedArg ( (A.At region _) as pattern, _ ) errors = + checkPatterns region BadArg [ pattern ] errors + + + +-- CHECK EXPRESSIONS + + +checkExpr : Can.Expr -> List Error -> List Error +checkExpr (A.At region expression) errors = + case expression of + Can.VarLocal _ -> + errors + + Can.VarTopLevel _ _ -> + errors + + Can.VarKernel _ _ -> + errors + + Can.VarForeign _ _ _ -> + errors + + Can.VarCtor _ _ _ _ _ -> + errors + + Can.VarDebug _ _ _ -> + errors + + Can.VarOperator _ _ _ _ -> + errors + + Can.Chr _ -> + errors + + Can.Str _ -> + errors + + Can.Int _ -> + errors + + Can.Float _ -> + errors + + Can.List entries -> + List.foldr checkExpr errors entries + + Can.Negate expr -> + checkExpr expr errors + + Can.Binop _ _ _ _ left right -> + checkExpr left + (checkExpr right errors) + + Can.Lambda args body -> + List.foldr checkArg (checkExpr body errors) args + + Can.Call func args -> + checkExpr func (List.foldr checkExpr errors args) + + Can.If branches finally -> + List.foldr checkIfBranch (checkExpr finally errors) branches + + Can.Let def body -> + checkDef def (checkExpr body errors) + + Can.LetRec defs body -> + List.foldr checkDef (checkExpr body errors) defs + + Can.LetDestruct ((A.At reg _) as pattern) expr body -> + checkPatterns reg BadDestruct [ pattern ] <| + checkExpr expr (checkExpr body errors) + + Can.Case expr branches -> + checkExpr expr (checkCases region branches errors) + + Can.Accessor _ -> + errors + + Can.Access record _ -> + checkExpr record errors + + Can.Update record fields -> + checkExpr record <| Dict.foldr A.compareLocated (\_ -> checkField) errors fields + + Can.Record fields -> + Dict.foldr A.compareLocated (\_ -> checkExpr) errors fields + + Can.Unit -> + errors + + Can.Tuple a b cs -> + checkExpr a + (checkExpr b + (List.foldr checkExpr errors cs) + ) + + Can.Shader _ _ -> + errors + + + +-- CHECK FIELD + + +checkField : Can.FieldUpdate -> List Error -> List Error +checkField (Can.FieldUpdate _ expr) errors = + checkExpr expr errors + + + +-- CHECK IF BRANCH + + +checkIfBranch : ( Can.Expr, Can.Expr ) -> List Error -> List Error +checkIfBranch ( condition, branch ) errs = + checkExpr condition (checkExpr branch errs) + + + +-- CHECK CASE EXPRESSION + + +checkCases : A.Region -> List Can.CaseBranch -> List Error -> List Error +checkCases region branches errors = + let + ( patterns, newErrors ) = + List.foldr checkCaseBranch ( [], errors ) branches + in + checkPatterns region BadCase patterns newErrors + + +checkCaseBranch : Can.CaseBranch -> ( List Can.Pattern, List Error ) -> ( List Can.Pattern, List Error ) +checkCaseBranch (Can.CaseBranch pattern expr) ( patterns, errors ) = + ( pattern :: patterns + , checkExpr expr errors + ) + + + +-- CHECK PATTERNS + + +checkPatterns : A.Region -> Context -> List Can.Pattern -> List Error -> List Error +checkPatterns region context patterns errors = + case toNonRedundantRows region patterns of + Err err -> + err :: errors + + Ok matrix -> + case isExhaustive matrix 1 of + [] -> + errors + + badPatterns -> + Incomplete region context (List.map Prelude.head badPatterns) :: errors + + + +-- EXHAUSTIVE PATTERNS +-- INVARIANTS: +-- +-- The initial rows "matrix" are all of length 1 +-- The initial count of items per row "n" is also 1 +-- The resulting rows are examples of missing patterns +-- + + +isExhaustive : List (List Pattern) -> Int -> List (List Pattern) +isExhaustive matrix n = + case matrix of + [] -> + [ List.repeat n Anything ] + + _ -> + if n == 0 then + [] + + else + let + ctors : Dict String Name.Name Can.Union + ctors = + collectCtors matrix + + numSeen : Int + numSeen = + Dict.size ctors + in + if numSeen == 0 then + List.map ((::) Anything) + (isExhaustive (List.filterMap specializeRowByAnything matrix) (n - 1)) + + else + let + ((Can.Union _ altList numAlts _) as alts) = + Tuple.second (Utils.mapFindMin ctors) + in + if numSeen < numAlts then + List.filterMap (isMissing alts ctors) altList + |> List.map (::) + |> List.andMap (isExhaustive (List.filterMap specializeRowByAnything matrix) (n - 1)) + + else + let + isAltExhaustive : Can.Ctor -> List (List Pattern) + isAltExhaustive (Can.Ctor name _ arity _) = + List.map (recoverCtor alts name arity) + (isExhaustive + (List.filterMap (specializeRowByCtor name arity) matrix) + (arity + n - 1) + ) + in + List.concatMap isAltExhaustive altList + + +isMissing : Can.Union -> Dict String Name.Name a -> Can.Ctor -> Maybe Pattern +isMissing union ctors (Can.Ctor name _ arity _) = + if Dict.member identity name ctors then + Nothing + + else + Just (Ctor union name (List.repeat arity Anything)) + + +recoverCtor : Can.Union -> Name.Name -> Int -> List Pattern -> List Pattern +recoverCtor union name arity patterns = + let + ( args, rest ) = + List.splitAt arity patterns + in + Ctor union name args :: rest + + + +-- REDUNDANT PATTERNS + + +{-| INVARIANT: Produces a list of rows where (forall row. length row == 1) +-} +toNonRedundantRows : A.Region -> List Can.Pattern -> Result Error (List (List Pattern)) +toNonRedundantRows region patterns = + toSimplifiedUsefulRows region [] patterns + + +{-| INVARIANT: Produces a list of rows where (forall row. length row == 1) +-} +toSimplifiedUsefulRows : A.Region -> List (List Pattern) -> List Can.Pattern -> Result Error (List (List Pattern)) +toSimplifiedUsefulRows overallRegion checkedRows uncheckedPatterns = + case uncheckedPatterns of + [] -> + Ok checkedRows + + ((A.At region _) as pattern) :: rest -> + let + nextRow : List Pattern + nextRow = + [ simplify pattern ] + in + if isUseful checkedRows nextRow then + toSimplifiedUsefulRows overallRegion (nextRow :: checkedRows) rest + + else + Err (Redundant overallRegion region (List.length checkedRows + 1)) + + + +-- Check if a new row "vector" is useful given previous rows "matrix" + + +isUseful : List (List Pattern) -> List Pattern -> Bool +isUseful matrix vector = + case matrix of + [] -> + -- No rows are the same as the new vector! The vector is useful! + True + + _ -> + case vector of + [] -> + -- There is nothing left in the new vector, but we still have + -- rows that match the same things. This is not a useful vector! + False + + firstPattern :: patterns -> + case firstPattern of + Ctor _ name args -> + -- keep checking rows that start with this Ctor or Anything + isUseful + (List.filterMap (specializeRowByCtor name (List.length args)) matrix) + (args ++ patterns) + + Anything -> + -- check if all alts appear in matrix + case isComplete matrix of + No -> + -- This Anything is useful because some Ctors are missing. + -- But what if a previous row has an Anything? + -- If so, this one is not useful. + isUseful (List.filterMap specializeRowByAnything matrix) patterns + + Yes alts -> + -- All Ctors are covered, so this Anything is not needed for any + -- of those. But what if some of those Ctors have subpatterns + -- that make them less general? If so, this actually is useful! + let + isUsefulAlt : Can.Ctor -> Bool + isUsefulAlt (Can.Ctor name _ arity _) = + isUseful + (List.filterMap (specializeRowByCtor name arity) matrix) + (List.repeat arity Anything ++ patterns) + in + List.any isUsefulAlt alts + + Literal literal -> + -- keep checking rows that start with this Literal or Anything + isUseful + (List.filterMap (specializeRowByLiteral literal) matrix) + patterns + + + +-- INVARIANT: (length row == N) ==> (length result == arity + N - 1) + + +specializeRowByCtor : Name.Name -> Int -> List Pattern -> Maybe (List Pattern) +specializeRowByCtor ctorName arity row = + case row of + (Ctor _ name args) :: patterns -> + if name == ctorName then + Just (args ++ patterns) + + else + Nothing + + Anything :: patterns -> + Just (List.repeat arity Anything ++ patterns) + + (Literal _) :: _ -> + crash <| + "Compiler bug! After type checking, constructors and literals should never align in pattern match exhaustiveness checks." + + [] -> + crash "Compiler error! Empty matrices should not get specialized." + + + +-- INVARIANT: (length row == N) ==> (length result == N-1) + + +specializeRowByLiteral : Literal -> List Pattern -> Maybe (List Pattern) +specializeRowByLiteral literal row = + case row of + (Literal lit) :: patterns -> + if lit == literal then + Just patterns + + else + Nothing + + Anything :: patterns -> + Just patterns + + (Ctor _ _ _) :: _ -> + crash <| + "Compiler bug! After type checking, constructors and literals should never align in pattern match exhaustiveness checks." + + [] -> + crash "Compiler error! Empty matrices should not get specialized." + + + +-- INVARIANT: (length row == N) ==> (length result == N-1) + + +specializeRowByAnything : List Pattern -> Maybe (List Pattern) +specializeRowByAnything row = + case row of + [] -> + Nothing + + (Ctor _ _ _) :: _ -> + Nothing + + Anything :: patterns -> + Just patterns + + (Literal _) :: _ -> + Nothing + + + +-- ALL CONSTRUCTORS ARE PRESENT? + + +type Complete + = Yes (List Can.Ctor) + | No + + +isComplete : List (List Pattern) -> Complete +isComplete matrix = + let + ctors : Dict String Name.Name Can.Union + ctors = + collectCtors matrix + + numSeen : Int + numSeen = + Dict.size ctors + in + if numSeen == 0 then + No + + else + let + (Can.Union _ alts numAlts _) = + Tuple.second (Utils.mapFindMin ctors) + in + if numSeen == numAlts then + Yes alts + + else + No + + + +-- COLLECT CTORS + + +collectCtors : List (List Pattern) -> Dict String Name.Name Can.Union +collectCtors matrix = + List.foldl (\row acc -> collectCtorsHelp acc row) Dict.empty matrix + + +collectCtorsHelp : Dict String Name.Name Can.Union -> List Pattern -> Dict String Name.Name Can.Union +collectCtorsHelp ctors row = + case row of + (Ctor union name _) :: _ -> + Dict.insert identity name union ctors + + _ -> + ctors + + + +-- ENCODERS and DECODERS + + +errorEncoder : Error -> BE.Encoder +errorEncoder error = + case error of + Incomplete region context unhandled -> + BE.sequence + [ BE.unsignedInt8 0 + , A.regionEncoder region + , contextEncoder context + , BE.list patternEncoder unhandled + ] + + Redundant caseRegion patternRegion index -> + BE.sequence + [ BE.unsignedInt8 1 + , A.regionEncoder caseRegion + , A.regionEncoder patternRegion + , BE.int index + ] + + +errorDecoder : BD.Decoder Error +errorDecoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.map3 Incomplete + A.regionDecoder + contextDecoder + (BD.list patternDecoder) + + 1 -> + BD.map3 Redundant + A.regionDecoder + A.regionDecoder + BD.int + + _ -> + BD.fail + ) + + +contextEncoder : Context -> BE.Encoder +contextEncoder context = + BE.unsignedInt8 + (case context of + BadArg -> + 0 + + BadDestruct -> + 1 + + BadCase -> + 2 + ) + + +contextDecoder : BD.Decoder Context +contextDecoder = + BD.unsignedInt8 + |> BD.andThen + (\str -> + case str of + 0 -> + BD.succeed BadArg + + 1 -> + BD.succeed BadDestruct + + 2 -> + BD.succeed BadCase + + _ -> + BD.fail + ) + + +patternEncoder : Pattern -> BE.Encoder +patternEncoder pattern = + case pattern of + Anything -> + BE.unsignedInt8 0 + + Literal index -> + BE.sequence + [ BE.unsignedInt8 1 + , literalEncoder index + ] + + Ctor union name args -> + BE.sequence + [ BE.unsignedInt8 2 + , Can.unionEncoder union + , BE.string name + , BE.list patternEncoder args + ] + + +patternDecoder : BD.Decoder Pattern +patternDecoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.succeed Anything + + 1 -> + BD.map Literal literalDecoder + + 2 -> + BD.map3 Ctor + Can.unionDecoder + BD.string + (BD.list patternDecoder) + + _ -> + BD.fail + ) + + +literalEncoder : Literal -> BE.Encoder +literalEncoder literal = + case literal of + Chr value -> + BE.sequence + [ BE.unsignedInt8 0 + , BE.string value + ] + + Str value -> + BE.sequence + [ BE.unsignedInt8 1 + , BE.string value + ] + + Int value -> + BE.sequence + [ BE.unsignedInt8 2 + , BE.int value + ] + + +literalDecoder : BD.Decoder Literal +literalDecoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.map Chr BD.string + + 1 -> + BD.map Str BD.string + + 2 -> + BD.map Int BD.int + + _ -> + BD.fail + ) diff --git a/src/Compiler/Optimize/Case.elm b/src/Compiler/Optimize/Case.elm new file mode 100644 index 0000000000..291d0474cf --- /dev/null +++ b/src/Compiler/Optimize/Case.elm @@ -0,0 +1,160 @@ +module Compiler.Optimize.Case exposing (optimize) + +import Compiler.AST.Canonical as Can +import Compiler.AST.Optimized as Opt +import Compiler.Data.Name as Name +import Compiler.Optimize.DecisionTree as DT +import Data.Map as Dict exposing (Dict) +import Prelude +import Utils.Crash exposing (crash) +import Utils.Main as Utils + + + +-- OPTIMIZE A CASE EXPRESSION + + +optimize : Name.Name -> Name.Name -> List ( Can.Pattern, Opt.Expr ) -> Opt.Expr +optimize temp root optBranches = + let + ( patterns, indexedBranches ) = + List.unzip (List.indexedMap indexify optBranches) + + decider : Opt.Decider Int + decider = + treeToDecider (DT.compile patterns) + + targetCounts : Dict Int Int Int + targetCounts = + countTargets decider + + ( choices, maybeJumps ) = + List.unzip (List.map (createChoices targetCounts) indexedBranches) + in + Opt.Case temp + root + (insertChoices (Dict.fromList identity choices) decider) + (List.filterMap identity maybeJumps) + + +indexify : Int -> ( a, b ) -> ( ( a, Int ), ( Int, b ) ) +indexify index ( pattern, branch ) = + ( ( pattern, index ) + , ( index, branch ) + ) + + + +-- TREE TO DECIDER +-- +-- Decision trees may have some redundancies, so we convert them to a Decider +-- which has special constructs to avoid code duplication when possible. + + +treeToDecider : DT.DecisionTree -> Opt.Decider Int +treeToDecider tree = + case tree of + DT.Match target -> + Opt.Leaf target + + -- zero options + DT.Decision _ [] Nothing -> + crash "compiler bug, somehow created an empty decision tree" + + -- one option + DT.Decision _ [ ( _, subTree ) ] Nothing -> + treeToDecider subTree + + DT.Decision _ [] (Just subTree) -> + treeToDecider subTree + + -- two options + DT.Decision path [ ( test, successTree ) ] (Just failureTree) -> + toChain path test successTree failureTree + + DT.Decision path [ ( test, successTree ), ( _, failureTree ) ] Nothing -> + toChain path test successTree failureTree + + -- many options + DT.Decision path edges Nothing -> + let + ( necessaryTests, fallback ) = + ( Prelude.init edges, Tuple.second (Prelude.last edges) ) + in + Opt.FanOut + path + (List.map (Tuple.mapSecond treeToDecider) necessaryTests) + (treeToDecider fallback) + + DT.Decision path edges (Just fallback) -> + Opt.FanOut path (List.map (Tuple.mapSecond treeToDecider) edges) (treeToDecider fallback) + + +toChain : DT.Path -> DT.Test -> DT.DecisionTree -> DT.DecisionTree -> Opt.Decider Int +toChain path test successTree failureTree = + let + failure : Opt.Decider Int + failure = + treeToDecider failureTree + in + case treeToDecider successTree of + (Opt.Chain testChain success subFailure) as success_ -> + if failure == subFailure then + Opt.Chain (( path, test ) :: testChain) success failure + + else + Opt.Chain [ ( path, test ) ] success_ failure + + success -> + Opt.Chain [ ( path, test ) ] success failure + + + +-- INSERT CHOICES +-- +-- If a target appears exactly once in a Decider, the corresponding expression +-- can be inlined. Whether things are inlined or jumps is called a "choice". + + +countTargets : Opt.Decider Int -> Dict Int Int Int +countTargets decisionTree = + case decisionTree of + Opt.Leaf target -> + Dict.singleton identity target 1 + + Opt.Chain _ success failure -> + Utils.mapUnionWith identity compare (+) (countTargets success) (countTargets failure) + + Opt.FanOut _ tests fallback -> + Utils.mapUnionsWith identity compare (+) (List.map countTargets (fallback :: List.map Tuple.second tests)) + + +createChoices : Dict Int Int Int -> ( Int, Opt.Expr ) -> ( ( Int, Opt.Choice ), Maybe ( Int, Opt.Expr ) ) +createChoices targetCounts ( target, branch ) = + if Dict.get identity target targetCounts == Just 1 then + ( ( target, Opt.Inline branch ) + , Nothing + ) + + else + ( ( target, Opt.Jump target ) + , Just ( target, branch ) + ) + + +insertChoices : Dict Int Int Opt.Choice -> Opt.Decider Int -> Opt.Decider Opt.Choice +insertChoices choiceDict decider = + let + go : Opt.Decider Int -> Opt.Decider Opt.Choice + go = + insertChoices choiceDict + in + case decider of + Opt.Leaf target -> + Opt.Leaf (Utils.find identity target choiceDict) + + Opt.Chain testChain success failure -> + Opt.Chain testChain (go success) (go failure) + + Opt.FanOut path tests fallback -> + Opt.FanOut path (List.map (Tuple.mapSecond go) tests) (go fallback) diff --git a/src/Compiler/Optimize/DecisionTree.elm b/src/Compiler/Optimize/DecisionTree.elm new file mode 100644 index 0000000000..24f81153ac --- /dev/null +++ b/src/Compiler/Optimize/DecisionTree.elm @@ -0,0 +1,821 @@ +module Compiler.Optimize.DecisionTree exposing + ( DecisionTree(..) + , Path(..) + , Test(..) + , compile + , pathDecoder + , pathEncoder + , testDecoder + , testEncoder + ) + +{- To learn more about how this works, definitely read through: + + "When Do Match-Compilation Heuristics Matter?" + + by Kevin Scott and Norman Ramsey. The rough idea is that we start with a simple + list of patterns and expressions, and then turn that into a "decision tree" + that requires as few tests as possible to make it to a leaf. Read the paper, it + explains this extraordinarily well! We are currently using the same heuristics + as SML/NJ to get nice trees. +-} + +import Compiler.AST.Canonical as Can +import Compiler.Data.Index as Index +import Compiler.Data.Name as Name +import Compiler.Elm.ModuleName as ModuleName +import Compiler.Reporting.Annotation as A +import Data.Set as EverySet +import Hex.Convert +import Prelude +import System.TypeCheck.IO as IO +import Utils.Bytes.Decode as BD +import Utils.Bytes.Encode as BE +import Utils.Crash exposing (crash) +import Utils.Main as Utils + + + +-- COMPILE CASES + + +{-| Users of this module will mainly interact with this function. It takes +some normal branches and gives out a decision tree that has "labels" at all +the leafs and a dictionary that maps these "labels" to the code that should +run. + +If 2 or more leaves point to the same label, we need to do some tricks in JS to +make that work nicely. When is JS getting goto?! ;) That is outside the scope +of this module though. + +-} +compile : List ( Can.Pattern, Int ) -> DecisionTree +compile rawBranches = + let + format : ( Can.Pattern, Int ) -> Branch + format ( pattern, index ) = + Branch index [ ( Empty, pattern ) ] + in + toDecisionTree (List.map format rawBranches) + + + +-- DECISION TREES + + +type DecisionTree + = Match Int + | Decision Path (List ( Test, DecisionTree )) (Maybe DecisionTree) + + +type Test + = IsCtor IO.Canonical Name.Name Index.ZeroBased Int Can.CtorOpts + | IsCons + | IsNil + | IsTuple + | IsInt Int + | IsChr String + | IsStr String + | IsBool Bool + + +type Path + = Index Index.ZeroBased Path + | Unbox Path + | Empty + + + +-- ACTUALLY BUILD DECISION TREES + + +type Branch + = Branch Int (List ( Path, Can.Pattern )) + + +toDecisionTree : List Branch -> DecisionTree +toDecisionTree rawBranches = + let + branches : List Branch + branches = + List.map flattenPatterns rawBranches + in + case checkForMatch branches of + Just goal -> + Match goal + + Nothing -> + let + path : Path + path = + pickPath branches + + ( edges, fallback ) = + gatherEdges branches path + + decisionEdges : List ( Test, DecisionTree ) + decisionEdges = + List.map (Tuple.mapSecond toDecisionTree) edges + in + case ( decisionEdges, fallback ) of + ( [ ( _, decisionTree ) ], [] ) -> + decisionTree + + ( _, [] ) -> + Decision path decisionEdges Nothing + + ( [], _ :: _ ) -> + toDecisionTree fallback + + _ -> + Decision path decisionEdges (Just (toDecisionTree fallback)) + + +isComplete : List Test -> Bool +isComplete tests = + case Prelude.head tests of + IsCtor _ _ _ numAlts _ -> + numAlts == List.length tests + + IsCons -> + List.length tests == 2 + + IsNil -> + List.length tests == 2 + + IsTuple -> + True + + IsInt _ -> + False + + IsChr _ -> + False + + IsStr _ -> + False + + IsBool _ -> + List.length tests == 2 + + + +-- FLATTEN PATTERNS + + +{-| Flatten type aliases and use the VariantDict to figure out when a tag is +the only variant so we can skip doing any tests on it. +-} +flattenPatterns : Branch -> Branch +flattenPatterns (Branch goal pathPatterns) = + Branch goal (List.foldr flatten [] pathPatterns) + + +flatten : ( Path, Can.Pattern ) -> List ( Path, Can.Pattern ) -> List ( Path, Can.Pattern ) +flatten (( path, A.At region pattern ) as pathPattern) otherPathPatterns = + case pattern of + Can.PVar _ -> + pathPattern :: otherPathPatterns + + Can.PAnything -> + pathPattern :: otherPathPatterns + + Can.PCtor { union, args } -> + let + (Can.Union _ _ numAlts _) = + union + in + if numAlts == 1 then + case List.map dearg args of + [ arg ] -> + flatten ( Unbox path, arg ) otherPathPatterns + + args_ -> + List.foldr flatten otherPathPatterns (subPositions path args_) + + else + pathPattern :: otherPathPatterns + + Can.PTuple a b cs -> + (a :: b :: cs) + |> List.foldl + (\x ( index, acc ) -> + ( Index.next index + , ( Index index path, x ) :: acc + ) + ) + ( Index.first, [] ) + |> Tuple.second + |> List.foldl flatten otherPathPatterns + + Can.PUnit -> + otherPathPatterns + + Can.PAlias realPattern alias -> + flatten ( path, realPattern ) <| + ( path, A.At region (Can.PVar alias) ) + :: otherPathPatterns + + Can.PRecord _ -> + pathPattern :: otherPathPatterns + + Can.PList _ -> + pathPattern :: otherPathPatterns + + Can.PCons _ _ -> + pathPattern :: otherPathPatterns + + Can.PChr _ -> + pathPattern :: otherPathPatterns + + Can.PStr _ _ -> + pathPattern :: otherPathPatterns + + Can.PInt _ -> + pathPattern :: otherPathPatterns + + Can.PBool _ _ -> + pathPattern :: otherPathPatterns + + +subPositions : Path -> List Can.Pattern -> List ( Path, Can.Pattern ) +subPositions path patterns = + Index.indexedMap (\index pattern -> ( Index index path, pattern )) patterns + + +dearg : Can.PatternCtorArg -> Can.Pattern +dearg (Can.PatternCtorArg _ _ pattern) = + pattern + + + +-- SUCCESSFULLY MATCH + + +{-| If the first branch has no more "decision points" we can finally take that +path. If that is the case we give the resulting label and a mapping from free +variables to "how to get their value". So a pattern like (Just (x,\_)) will give +us something like ("x" => value.0.0) +-} +checkForMatch : List Branch -> Maybe Int +checkForMatch branches = + case branches of + (Branch goal patterns) :: _ -> + if List.all (not << needsTests << Tuple.second) patterns then + Just goal + + else + Nothing + + _ -> + Nothing + + + +-- GATHER OUTGOING EDGES + + +gatherEdges : List Branch -> Path -> ( List ( Test, List Branch ), List Branch ) +gatherEdges branches path = + let + relevantTests : List Test + relevantTests = + testsAtPath path branches + + allEdges : List ( Test, List Branch ) + allEdges = + List.map (edgesFor path branches) relevantTests + + fallbacks : List Branch + fallbacks = + if isComplete relevantTests then + [] + + else + List.filter (isIrrelevantTo path) branches + in + ( allEdges, fallbacks ) + + + +-- FIND RELEVANT TESTS + + +testsAtPath : Path -> List Branch -> List Test +testsAtPath selectedPath branches = + let + allTests : List Test + allTests = + List.filterMap (testAtPath selectedPath) branches + + skipVisited : Test -> ( List Test, EverySet.EverySet String Test ) -> ( List Test, EverySet.EverySet String Test ) + skipVisited test (( uniqueTests, visitedTests ) as curr) = + if EverySet.member (Hex.Convert.toString << BE.encode << testEncoder) test visitedTests then + curr + + else + ( test :: uniqueTests + , EverySet.insert (Hex.Convert.toString << BE.encode << testEncoder) test visitedTests + ) + in + Tuple.first (List.foldr skipVisited ( [], EverySet.empty ) allTests) + + +testAtPath : Path -> Branch -> Maybe Test +testAtPath selectedPath (Branch _ pathPatterns) = + Utils.listLookup selectedPath pathPatterns + |> Maybe.andThen + (\(A.At _ pattern) -> + case pattern of + Can.PCtor { home, union, name, index } -> + let + (Can.Union _ _ numAlts opts) = + union + in + Just (IsCtor home name index numAlts opts) + + Can.PList ps -> + Just + (case ps of + [] -> + IsNil + + _ -> + IsCons + ) + + Can.PCons _ _ -> + Just IsCons + + Can.PTuple _ _ _ -> + Just IsTuple + + Can.PUnit -> + Just IsTuple + + Can.PVar _ -> + Nothing + + Can.PAnything -> + Nothing + + Can.PInt int -> + Just (IsInt int) + + Can.PStr str _ -> + Just (IsStr str) + + Can.PChr chr -> + Just (IsChr chr) + + Can.PBool _ bool -> + Just (IsBool bool) + + Can.PRecord _ -> + Nothing + + Can.PAlias _ _ -> + crash "aliases should never reach 'testAtPath' function" + ) + + + +-- BUILD EDGES + + +edgesFor : Path -> List Branch -> Test -> ( Test, List Branch ) +edgesFor path branches test = + ( test + , List.filterMap (toRelevantBranch test path) branches + ) + + +toRelevantBranch : Test -> Path -> Branch -> Maybe Branch +toRelevantBranch test path ((Branch goal pathPatterns) as branch) = + case extract path pathPatterns of + Found start (A.At region pattern) end -> + case pattern of + Can.PCtor { union, name, args } -> + case test of + IsCtor _ testName _ _ _ -> + if name == testName then + Just + (Branch goal <| + case List.map dearg args of + (arg :: []) as args_ -> + let + (Can.Union _ _ numAlts _) = + union + in + if numAlts == 1 then + start ++ (( Unbox path, arg ) :: end) + + else + start ++ subPositions path args_ ++ end + + args_ -> + start ++ subPositions path args_ ++ end + ) + + else + Nothing + + _ -> + Nothing + + Can.PList [] -> + case test of + IsNil -> + Just (Branch goal (start ++ end)) + + _ -> + Nothing + + Can.PList (hd :: tl) -> + case test of + IsCons -> + let + tl_ : A.Located Can.Pattern_ + tl_ = + A.At region (Can.PList tl) + in + Just (Branch goal (start ++ subPositions path [ hd, tl_ ] ++ end)) + + _ -> + Nothing + + Can.PCons hd tl -> + case test of + IsCons -> + Just (Branch goal (start ++ subPositions path [ hd, tl ] ++ end)) + + _ -> + Nothing + + Can.PChr chr -> + case test of + IsChr testChr -> + if chr == testChr then + Just (Branch goal (start ++ end)) + + else + Nothing + + _ -> + Nothing + + Can.PStr str _ -> + case test of + IsStr testStr -> + if str == testStr then + Just (Branch goal (start ++ end)) + + else + Nothing + + _ -> + Nothing + + Can.PInt int -> + case test of + IsInt testInt -> + if int == testInt then + Just (Branch goal (start ++ end)) + + else + Nothing + + _ -> + Nothing + + Can.PBool _ bool -> + case test of + IsBool testBool -> + if bool == testBool then + Just (Branch goal (start ++ end)) + + else + Nothing + + _ -> + Nothing + + Can.PUnit -> + Just (Branch goal (start ++ end)) + + Can.PTuple a b cs -> + Just + (Branch goal + (start + ++ subPositions path (a :: b :: cs) + ++ end + ) + ) + + Can.PVar _ -> + Just branch + + Can.PAnything -> + Just branch + + Can.PRecord _ -> + Just branch + + Can.PAlias _ _ -> + Just branch + + NotFound -> + Just branch + + +type Extract + = NotFound + | Found (List ( Path, Can.Pattern )) Can.Pattern (List ( Path, Can.Pattern )) + + +extract : Path -> List ( Path, Can.Pattern ) -> Extract +extract selectedPath pathPatterns = + case pathPatterns of + [] -> + NotFound + + (( path, pattern ) as first) :: rest -> + if path == selectedPath then + Found [] pattern rest + + else + case extract selectedPath rest of + NotFound -> + NotFound + + Found start foundPattern end -> + Found (first :: start) foundPattern end + + + +-- FIND IRRELEVANT BRANCHES + + +isIrrelevantTo : Path -> Branch -> Bool +isIrrelevantTo selectedPath (Branch _ pathPatterns) = + case Utils.listLookup selectedPath pathPatterns of + Nothing -> + True + + Just pattern -> + not (needsTests pattern) + + +needsTests : Can.Pattern -> Bool +needsTests (A.At _ pattern) = + case pattern of + Can.PVar _ -> + False + + Can.PAnything -> + False + + Can.PRecord _ -> + False + + Can.PCtor _ -> + True + + Can.PList _ -> + True + + Can.PCons _ _ -> + True + + Can.PUnit -> + True + + Can.PTuple _ _ _ -> + True + + Can.PChr _ -> + True + + Can.PStr _ _ -> + True + + Can.PInt _ -> + True + + Can.PBool _ _ -> + True + + Can.PAlias _ _ -> + crash "aliases should never reach 'isIrrelevantTo' function" + + + +-- PICK A PATH + + +pickPath : List Branch -> Path +pickPath branches = + let + allPaths : List Path + allPaths = + List.filterMap isChoicePath (List.concatMap (\(Branch _ patterns) -> patterns) branches) + in + case bests (addWeights (smallDefaults branches) allPaths) of + [ path ] -> + path + + tiedPaths -> + Prelude.head (bests (addWeights (smallBranchingFactor branches) tiedPaths)) + + +isChoicePath : ( Path, Can.Pattern ) -> Maybe Path +isChoicePath ( path, pattern ) = + if needsTests pattern then + Just path + + else + Nothing + + +addWeights : (Path -> Int) -> List Path -> List ( Path, Int ) +addWeights toWeight paths = + List.map (\path -> ( path, toWeight path )) paths + + +bests : List ( Path, Int ) -> List Path +bests allPaths = + case allPaths of + [] -> + crash "Cannot choose the best of zero paths. This should never happen." + + ( headPath, headWeight ) :: weightedPaths -> + let + gatherMinimum : ( a, comparable ) -> ( comparable, List a ) -> ( comparable, List a ) + gatherMinimum ( path, weight ) (( minWeight, paths ) as acc) = + if weight == minWeight then + ( minWeight, path :: paths ) + + else if weight < minWeight then + ( weight, [ path ] ) + + else + acc + in + Tuple.second (List.foldl gatherMinimum ( headWeight, [ headPath ] ) weightedPaths) + + + +-- PATH PICKING HEURISTICS + + +smallDefaults : List Branch -> Path -> Int +smallDefaults branches path = + List.length (List.filter (isIrrelevantTo path) branches) + + +smallBranchingFactor : List Branch -> Path -> Int +smallBranchingFactor branches path = + let + ( edges, fallback ) = + gatherEdges branches path + in + List.length edges + + (if List.isEmpty fallback then + 0 + + else + 1 + ) + + + +-- ENCODERS and DECODERS + + +pathEncoder : Path -> BE.Encoder +pathEncoder path_ = + case path_ of + Index index path -> + BE.sequence + [ BE.unsignedInt8 0 + , Index.zeroBasedEncoder index + , pathEncoder path + ] + + Unbox path -> + BE.sequence + [ BE.unsignedInt8 1 + , pathEncoder path + ] + + Empty -> + BE.unsignedInt8 2 + + +pathDecoder : BD.Decoder Path +pathDecoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.map2 Index + Index.zeroBasedDecoder + pathDecoder + + 1 -> + BD.map Unbox pathDecoder + + 2 -> + BD.succeed Empty + + _ -> + BD.fail + ) + + +testEncoder : Test -> BE.Encoder +testEncoder test = + case test of + IsCtor home name index numAlts opts -> + BE.sequence + [ BE.unsignedInt8 0 + , ModuleName.canonicalEncoder home + , BE.string name + , Index.zeroBasedEncoder index + , BE.int numAlts + , Can.ctorOptsEncoder opts + ] + + IsCons -> + BE.unsignedInt8 1 + + IsNil -> + BE.unsignedInt8 2 + + IsTuple -> + BE.unsignedInt8 3 + + IsInt value -> + BE.sequence + [ BE.unsignedInt8 4 + , BE.int value + ] + + IsChr value -> + BE.sequence + [ BE.unsignedInt8 5 + , BE.string value + ] + + IsStr value -> + BE.sequence + [ BE.unsignedInt8 6 + , BE.string value + ] + + IsBool value -> + BE.sequence + [ BE.unsignedInt8 7 + , BE.bool value + ] + + +testDecoder : BD.Decoder Test +testDecoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.map5 IsCtor + ModuleName.canonicalDecoder + BD.string + Index.zeroBasedDecoder + BD.int + Can.ctorOptsDecoder + + 1 -> + BD.succeed IsCons + + 2 -> + BD.succeed IsNil + + 3 -> + BD.succeed IsTuple + + 4 -> + BD.map IsInt BD.int + + 5 -> + BD.map IsChr BD.string + + 6 -> + BD.map IsStr BD.string + + 7 -> + BD.map IsBool BD.bool + + _ -> + BD.fail + ) diff --git a/src/Compiler/Optimize/Expression.elm b/src/Compiler/Optimize/Expression.elm new file mode 100644 index 0000000000..26b9f92a49 --- /dev/null +++ b/src/Compiler/Optimize/Expression.elm @@ -0,0 +1,707 @@ +module Compiler.Optimize.Expression exposing + ( Cycle + , destructArgs + , optimize + , optimizePotentialTailCall + ) + +import Compiler.AST.Canonical as Can +import Compiler.AST.Optimized as Opt +import Compiler.AST.Utils.Shader as Shader +import Compiler.Data.Index as Index +import Compiler.Data.Name as Name +import Compiler.Elm.ModuleName as ModuleName +import Compiler.Optimize.Case as Case +import Compiler.Optimize.Names as Names +import Compiler.Reporting.Annotation as A +import Data.Map as Dict +import Data.Set as EverySet exposing (EverySet) +import Utils.Main as Utils + + + +-- OPTIMIZE + + +type alias Cycle = + EverySet String Name.Name + + +optimize : Cycle -> Can.Expr -> Names.Tracker Opt.Expr +optimize cycle (A.At region expression) = + case expression of + Can.VarLocal name -> + Names.pure (Opt.TrackedVarLocal region name) + + Can.VarTopLevel home name -> + if EverySet.member identity name cycle then + Names.pure (Opt.VarCycle region home name) + + else + Names.registerGlobal region home name + + Can.VarKernel home name -> + Names.registerKernel home (Opt.VarKernel region home name) + + Can.VarForeign home name _ -> + Names.registerGlobal region home name + + Can.VarCtor opts home name index _ -> + Names.registerCtor region home (A.At region name) index opts + + Can.VarDebug home name _ -> + Names.registerDebug name home region + + Can.VarOperator _ home name _ -> + Names.registerGlobal region home name + + Can.Chr chr -> + Names.registerKernel Name.utils (Opt.Chr region chr) + + Can.Str str -> + Names.pure (Opt.Str region str) + + Can.Int int -> + Names.pure (Opt.Int region int) + + Can.Float float -> + Names.pure (Opt.Float region float) + + Can.List entries -> + Names.traverse (optimize cycle) entries + |> Names.bind (Names.registerKernel Name.list << Opt.List region) + + Can.Negate expr -> + Names.registerGlobal region ModuleName.basics Name.negate + |> Names.bind + (\func -> + optimize cycle expr + |> Names.fmap + (\arg -> + Opt.Call region func [ arg ] + ) + ) + + Can.Binop _ home name _ left right -> + Names.registerGlobal region home name + |> Names.bind + (\optFunc -> + optimize cycle left + |> Names.bind + (\optLeft -> + optimize cycle right + |> Names.fmap + (\optRight -> + Opt.Call region optFunc [ optLeft, optRight ] + ) + ) + ) + + Can.Lambda args body -> + destructArgs args + |> Names.bind + (\( argNames, destructors ) -> + optimize cycle body + |> Names.fmap + (\obody -> + Opt.TrackedFunction argNames (List.foldr Opt.Destruct obody destructors) + ) + ) + + Can.Call func args -> + optimize cycle func + |> Names.bind + (\optimizeExpr -> + Names.traverse (optimize cycle) args + |> Names.fmap (Opt.Call region optimizeExpr) + ) + + Can.If branches finally -> + let + optimizeBranch : ( Can.Expr, Can.Expr ) -> Names.Tracker ( Opt.Expr, Opt.Expr ) + optimizeBranch ( condition, branch ) = + optimize cycle condition + |> Names.bind + (\expr -> + optimize cycle branch + |> Names.fmap (Tuple.pair expr) + ) + in + Names.traverse optimizeBranch branches + |> Names.bind + (\optimizedBranches -> + optimize cycle finally + |> Names.fmap (Opt.If optimizedBranches) + ) + + Can.Let def body -> + optimize cycle body + |> Names.bind (optimizeDef cycle def) + + Can.LetRec defs body -> + case defs of + [ def ] -> + optimizePotentialTailCallDef cycle def + |> Names.bind + (\tailCallDef -> + optimize cycle body + |> Names.fmap (Opt.Let tailCallDef) + ) + + _ -> + List.foldl + (\def bod -> + Names.bind (optimizeDef cycle def) bod + ) + (optimize cycle body) + defs + + Can.LetDestruct pattern expr body -> + destruct pattern + |> Names.bind + (\( A.At nameRegion name, destructs ) -> + optimize cycle expr + |> Names.bind + (\oexpr -> + optimize cycle body + |> Names.fmap + (\obody -> + Opt.Let (Opt.Def nameRegion name oexpr) (List.foldr Opt.Destruct obody destructs) + ) + ) + ) + + Can.Case expr branches -> + let + optimizeBranch : Name.Name -> Can.CaseBranch -> Names.Tracker ( Can.Pattern, Opt.Expr ) + optimizeBranch root (Can.CaseBranch pattern branch) = + destructCase root pattern + |> Names.bind + (\destructors -> + optimize cycle branch + |> Names.fmap + (\obranch -> + ( pattern, List.foldr Opt.Destruct obranch destructors ) + ) + ) + in + Names.generate + |> Names.bind + (\temp -> + optimize cycle expr + |> Names.bind + (\oexpr -> + case oexpr of + Opt.VarLocal root -> + Names.traverse (optimizeBranch root) branches + |> Names.fmap (Case.optimize temp root) + + Opt.TrackedVarLocal _ root -> + Names.traverse (optimizeBranch root) branches + |> Names.fmap (Case.optimize temp root) + + _ -> + Names.traverse (optimizeBranch temp) branches + |> Names.fmap + (\obranches -> + Opt.Let (Opt.Def region temp oexpr) (Case.optimize temp temp obranches) + ) + ) + ) + + Can.Accessor field -> + Names.registerField field (Opt.Accessor region field) + + Can.Access record (A.At fieldPosition field) -> + optimize cycle record + |> Names.bind + (\optRecord -> + Names.registerField field (Opt.Access optRecord fieldPosition field) + ) + + Can.Update record updates -> + Names.mapTraverse A.toValue A.compareLocated (optimizeUpdate cycle) updates + |> Names.bind + (\optUpdates -> + optimize cycle record + |> Names.bind + (\optRecord -> + Names.registerFieldDict (Utils.mapMapKeys identity A.compareLocated A.toValue updates) (Opt.Update region optRecord optUpdates) + ) + ) + + Can.Record fields -> + Names.mapTraverse A.toValue A.compareLocated (optimize cycle) fields + |> Names.bind + (\optFields -> + Names.registerFieldDict (Utils.mapMapKeys identity A.compareLocated A.toValue fields) (Opt.TrackedRecord region optFields) + ) + + Can.Unit -> + Names.registerKernel Name.utils Opt.Unit + + Can.Tuple a b cs -> + optimize cycle a + |> Names.bind + (\optA -> + optimize cycle b + |> Names.bind + (\optB -> + Names.traverse (optimize cycle) cs + |> Names.bind (Names.registerKernel Name.utils << Opt.Tuple region optA optB) + ) + ) + + Can.Shader src (Shader.Types attributes uniforms _) -> + Names.pure (Opt.Shader src (EverySet.fromList identity (Dict.keys compare attributes)) (EverySet.fromList identity (Dict.keys compare uniforms))) + + + +-- UPDATE + + +optimizeUpdate : Cycle -> Can.FieldUpdate -> Names.Tracker Opt.Expr +optimizeUpdate cycle (Can.FieldUpdate _ expr) = + optimize cycle expr + + + +-- DEFINITION + + +optimizeDef : Cycle -> Can.Def -> Opt.Expr -> Names.Tracker Opt.Expr +optimizeDef cycle def body = + case def of + Can.Def (A.At region name) args expr -> + optimizeDefHelp cycle region name args expr body + + Can.TypedDef (A.At region name) _ typedArgs expr _ -> + optimizeDefHelp cycle region name (List.map Tuple.first typedArgs) expr body + + +optimizeDefHelp : Cycle -> A.Region -> Name.Name -> List Can.Pattern -> Can.Expr -> Opt.Expr -> Names.Tracker Opt.Expr +optimizeDefHelp cycle region name args expr body = + case args of + [] -> + optimize cycle expr + |> Names.fmap (\oexpr -> Opt.Let (Opt.Def region name oexpr) body) + + _ -> + optimize cycle expr + |> Names.bind + (\oexpr -> + destructArgs args + |> Names.fmap + (\( argNames, destructors ) -> + let + ofunc : Opt.Expr + ofunc = + Opt.TrackedFunction argNames (List.foldr Opt.Destruct oexpr destructors) + in + Opt.Let (Opt.Def region name ofunc) body + ) + ) + + + +-- DESTRUCTURING + + +destructArgs : List Can.Pattern -> Names.Tracker ( List (A.Located Name.Name), List Opt.Destructor ) +destructArgs args = + Names.traverse destruct args + |> Names.fmap List.unzip + |> Names.fmap + (\( argNames, destructorLists ) -> + ( argNames, List.concat destructorLists ) + ) + + +destructCase : Name.Name -> Can.Pattern -> Names.Tracker (List Opt.Destructor) +destructCase rootName pattern = + destructHelp (Opt.Root rootName) pattern [] + |> Names.fmap List.reverse + + +destruct : Can.Pattern -> Names.Tracker ( A.Located Name.Name, List Opt.Destructor ) +destruct ((A.At region ptrn) as pattern) = + case ptrn of + Can.PVar name -> + Names.pure ( A.At region name, [] ) + + Can.PAlias subPattern name -> + destructHelp (Opt.Root name) subPattern [] + |> Names.fmap (\revDs -> ( A.At region name, List.reverse revDs )) + + _ -> + Names.generate + |> Names.bind + (\name -> + destructHelp (Opt.Root name) pattern [] + |> Names.fmap + (\revDs -> + ( A.At region name, List.reverse revDs ) + ) + ) + + +destructHelp : Opt.Path -> Can.Pattern -> List Opt.Destructor -> Names.Tracker (List Opt.Destructor) +destructHelp path (A.At region pattern) revDs = + case pattern of + Can.PAnything -> + Names.pure revDs + + Can.PVar name -> + Names.pure (Opt.Destructor name path :: revDs) + + Can.PRecord fields -> + let + toDestruct : Name.Name -> Opt.Destructor + toDestruct name = + Opt.Destructor name (Opt.Field name path) + in + Names.registerFieldList fields (List.map toDestruct fields ++ revDs) + + Can.PAlias subPattern name -> + destructHelp (Opt.Root name) subPattern <| + (Opt.Destructor name path :: revDs) + + Can.PUnit -> + Names.pure revDs + + Can.PTuple a b [] -> + destructTwo path a b revDs + + Can.PTuple a b [ c ] -> + case path of + Opt.Root _ -> + destructHelp (Opt.Index Index.first path) a revDs + |> Names.bind (destructHelp (Opt.Index Index.second path) b) + |> Names.bind (destructHelp (Opt.Index Index.third path) c) + + _ -> + Names.generate + |> Names.bind + (\name -> + let + newRoot : Opt.Path + newRoot = + Opt.Root name + in + destructHelp (Opt.Index Index.first newRoot) a (Opt.Destructor name path :: revDs) + |> Names.bind (destructHelp (Opt.Index Index.second newRoot) b) + |> Names.bind (destructHelp (Opt.Index Index.third newRoot) c) + ) + + Can.PTuple a b cs -> + case path of + Opt.Root _ -> + List.foldl (\( index, arg ) -> Names.bind (destructHelp (Opt.ArrayIndex index (Opt.Field "cs" path)) arg)) + (destructHelp (Opt.Index Index.first path) a revDs + |> Names.bind (destructHelp (Opt.Index Index.second path) b) + ) + (List.indexedMap Tuple.pair cs) + + _ -> + Names.generate + |> Names.bind + (\name -> + let + newRoot : Opt.Path + newRoot = + Opt.Root name + in + List.foldl (\( index, arg ) -> Names.bind (destructHelp (Opt.ArrayIndex index (Opt.Field "cs" newRoot)) arg)) + (destructHelp (Opt.Index Index.first newRoot) a (Opt.Destructor name path :: revDs) + |> Names.bind (destructHelp (Opt.Index Index.second newRoot) b) + ) + (List.indexedMap Tuple.pair cs) + ) + + Can.PList [] -> + Names.pure revDs + + Can.PList (hd :: tl) -> + destructTwo path hd (A.At region (Can.PList tl)) revDs + + Can.PCons hd tl -> + destructTwo path hd tl revDs + + Can.PChr _ -> + Names.pure revDs + + Can.PStr _ _ -> + Names.pure revDs + + Can.PInt _ -> + Names.pure revDs + + Can.PBool _ _ -> + Names.pure revDs + + Can.PCtor { union, args } -> + case args of + [ Can.PatternCtorArg _ _ arg ] -> + let + (Can.Union _ _ _ opts) = + union + in + case opts of + Can.Normal -> + destructHelp (Opt.Index Index.first path) arg revDs + + Can.Unbox -> + destructHelp (Opt.Unbox path) arg revDs + + Can.Enum -> + destructHelp (Opt.Index Index.first path) arg revDs + + _ -> + case path of + Opt.Root _ -> + List.foldl (\arg -> Names.bind (\revDs_ -> destructCtorArg path revDs_ arg)) + (Names.pure revDs) + args + + _ -> + Names.generate + |> Names.bind + (\name -> + List.foldl (\arg -> Names.bind (\revDs_ -> destructCtorArg (Opt.Root name) revDs_ arg)) + (Names.pure (Opt.Destructor name path :: revDs)) + args + ) + + +destructTwo : Opt.Path -> Can.Pattern -> Can.Pattern -> List Opt.Destructor -> Names.Tracker (List Opt.Destructor) +destructTwo path a b revDs = + case path of + Opt.Root _ -> + destructHelp (Opt.Index Index.first path) a revDs + |> Names.bind (destructHelp (Opt.Index Index.second path) b) + + _ -> + Names.generate + |> Names.bind + (\name -> + let + newRoot : Opt.Path + newRoot = + Opt.Root name + in + destructHelp (Opt.Index Index.first newRoot) a (Opt.Destructor name path :: revDs) + |> Names.bind (destructHelp (Opt.Index Index.second newRoot) b) + ) + + +destructCtorArg : Opt.Path -> List Opt.Destructor -> Can.PatternCtorArg -> Names.Tracker (List Opt.Destructor) +destructCtorArg path revDs (Can.PatternCtorArg index _ arg) = + destructHelp (Opt.Index index path) arg revDs + + + +-- TAIL CALL + + +optimizePotentialTailCallDef : Cycle -> Can.Def -> Names.Tracker Opt.Def +optimizePotentialTailCallDef cycle def = + case def of + Can.Def (A.At region name) args expr -> + optimizePotentialTailCall cycle region name args expr + + Can.TypedDef (A.At region name) _ typedArgs expr _ -> + optimizePotentialTailCall cycle region name (List.map Tuple.first typedArgs) expr + + +optimizePotentialTailCall : Cycle -> A.Region -> Name.Name -> List Can.Pattern -> Can.Expr -> Names.Tracker Opt.Def +optimizePotentialTailCall cycle region name args expr = + destructArgs args + |> Names.bind + (\( argNames, destructors ) -> + optimizeTail cycle name argNames expr + |> Names.fmap (toTailDef region name argNames destructors) + ) + + +optimizeTail : Cycle -> Name.Name -> List (A.Located Name.Name) -> Can.Expr -> Names.Tracker Opt.Expr +optimizeTail cycle rootName argNames ((A.At region expression) as locExpr) = + case expression of + Can.Call func args -> + Names.traverse (optimize cycle) args + |> Names.bind + (\oargs -> + let + isMatchingName : Bool + isMatchingName = + case A.toValue func of + Can.VarLocal name -> + rootName == name + + Can.VarTopLevel _ name -> + rootName == name + + _ -> + False + in + if isMatchingName then + case Index.indexedZipWith (\_ a b -> ( A.toValue a, b )) argNames oargs of + Index.LengthMatch pairs -> + Names.pure (Opt.TailCall rootName pairs) + + Index.LengthMismatch _ _ -> + optimize cycle func + |> Names.fmap (\ofunc -> Opt.Call region ofunc oargs) + + else + optimize cycle func + |> Names.fmap (\ofunc -> Opt.Call region ofunc oargs) + ) + + Can.If branches finally -> + let + optimizeBranch : ( Can.Expr, Can.Expr ) -> Names.Tracker ( Opt.Expr, Opt.Expr ) + optimizeBranch ( condition, branch ) = + optimize cycle condition + |> Names.bind + (\optimizeCondition -> + optimizeTail cycle rootName argNames branch + |> Names.fmap (Tuple.pair optimizeCondition) + ) + in + Names.traverse optimizeBranch branches + |> Names.bind + (\obranches -> + optimizeTail cycle rootName argNames finally + |> Names.fmap (Opt.If obranches) + ) + + Can.Let def body -> + optimizeTail cycle rootName argNames body + |> Names.bind (optimizeDef cycle def) + + Can.LetRec defs body -> + case defs of + [ def ] -> + optimizePotentialTailCallDef cycle def + |> Names.bind + (\obody -> + optimizeTail cycle rootName argNames body + |> Names.fmap (Opt.Let obody) + ) + + _ -> + List.foldl + (\def bod -> + Names.bind (optimizeDef cycle def) bod + ) + (optimize cycle body) + defs + + Can.LetDestruct pattern expr body -> + destruct pattern + |> Names.bind + (\( A.At dregion dname, destructors ) -> + optimize cycle expr + |> Names.bind + (\oexpr -> + optimizeTail cycle rootName argNames body + |> Names.fmap + (\obody -> + Opt.Let (Opt.Def dregion dname oexpr) (List.foldr Opt.Destruct obody destructors) + ) + ) + ) + + Can.Case expr branches -> + let + optimizeBranch : Name.Name -> Can.CaseBranch -> Names.Tracker ( Can.Pattern, Opt.Expr ) + optimizeBranch root (Can.CaseBranch pattern branch) = + destructCase root pattern + |> Names.bind + (\destructors -> + optimizeTail cycle rootName argNames branch + |> Names.fmap + (\obranch -> + ( pattern, List.foldr Opt.Destruct obranch destructors ) + ) + ) + in + Names.generate + |> Names.bind + (\temp -> + optimize cycle expr + |> Names.bind + (\oexpr -> + case oexpr of + Opt.VarLocal root -> + Names.traverse (optimizeBranch root) branches + |> Names.fmap (Case.optimize temp root) + + Opt.TrackedVarLocal _ root -> + Names.traverse (optimizeBranch root) branches + |> Names.fmap (Case.optimize temp root) + + _ -> + Names.traverse (optimizeBranch temp) branches + |> Names.fmap + (\obranches -> + Opt.Let (Opt.Def region temp oexpr) (Case.optimize temp temp obranches) + ) + ) + ) + + _ -> + optimize cycle locExpr + + + +-- DETECT TAIL CALLS + + +toTailDef : A.Region -> Name.Name -> List (A.Located Name.Name) -> List Opt.Destructor -> Opt.Expr -> Opt.Def +toTailDef region name argNames destructors body = + if hasTailCall body then + Opt.TailDef region name argNames (List.foldr Opt.Destruct body destructors) + + else + Opt.Def region name (Opt.TrackedFunction argNames (List.foldr Opt.Destruct body destructors)) + + +hasTailCall : Opt.Expr -> Bool +hasTailCall expression = + case expression of + Opt.TailCall _ _ -> + True + + Opt.If branches finally -> + hasTailCall finally || List.any (hasTailCall << Tuple.second) branches + + Opt.Let _ body -> + hasTailCall body + + Opt.Destruct _ body -> + hasTailCall body + + Opt.Case _ _ decider jumps -> + decidecHasTailCall decider || List.any (hasTailCall << Tuple.second) jumps + + _ -> + False + + +decidecHasTailCall : Opt.Decider Opt.Choice -> Bool +decidecHasTailCall decider = + case decider of + Opt.Leaf choice -> + case choice of + Opt.Inline expr -> + hasTailCall expr + + Opt.Jump _ -> + False + + Opt.Chain _ success failure -> + decidecHasTailCall success || decidecHasTailCall failure + + Opt.FanOut _ tests fallback -> + decidecHasTailCall fallback || List.any (decidecHasTailCall << Tuple.second) tests diff --git a/src/Compiler/Optimize/Module.elm b/src/Compiler/Optimize/Module.elm new file mode 100644 index 0000000000..b9715058df --- /dev/null +++ b/src/Compiler/Optimize/Module.elm @@ -0,0 +1,472 @@ +module Compiler.Optimize.Module exposing + ( Annotations + , MResult + , optimize + ) + +import Compiler.AST.Canonical as Can +import Compiler.AST.Optimized as Opt +import Compiler.AST.Utils.Type as Type +import Compiler.Canonicalize.Effects as Effects +import Compiler.Data.Name as Name +import Compiler.Elm.ModuleName as ModuleName +import Compiler.Optimize.Expression as Expr +import Compiler.Optimize.Names as Names +import Compiler.Optimize.Port as Port +import Compiler.Reporting.Annotation as A +import Compiler.Reporting.Error.Main as E +import Compiler.Reporting.Result as R +import Compiler.Reporting.Warning as W +import Data.Map as Dict exposing (Dict) +import Data.Set as EverySet exposing (EverySet) +import System.TypeCheck.IO as IO +import Utils.Main as Utils + + + +-- OPTIMIZE + + +type alias MResult i w a = + R.RResult i w E.Error a + + +type alias Annotations = + Dict String Name.Name Can.Annotation + + +optimize : Annotations -> Can.Module -> MResult i (List W.Warning) Opt.LocalGraph +optimize annotations (Can.Module home _ _ decls unions aliases _ effects) = + addDecls home annotations decls <| + addEffects home effects <| + addUnions home unions <| + addAliases home aliases <| + Opt.LocalGraph Nothing Dict.empty Dict.empty + + + +-- UNION + + +type alias Nodes = + Dict (List String) Opt.Global Opt.Node + + +addUnions : IO.Canonical -> Dict String Name.Name Can.Union -> Opt.LocalGraph -> Opt.LocalGraph +addUnions home unions (Opt.LocalGraph main nodes fields) = + Opt.LocalGraph main (Dict.foldr compare (\_ -> addUnion home) nodes unions) fields + + +addUnion : IO.Canonical -> Can.Union -> Nodes -> Nodes +addUnion home (Can.Union _ ctors _ opts) nodes = + List.foldl (addCtorNode home opts) nodes ctors + + +addCtorNode : IO.Canonical -> Can.CtorOpts -> Can.Ctor -> Nodes -> Nodes +addCtorNode home opts (Can.Ctor name index numArgs _) nodes = + let + node : Opt.Node + node = + case opts of + Can.Normal -> + Opt.Ctor index numArgs + + Can.Unbox -> + Opt.Box + + Can.Enum -> + Opt.Enum index + in + Dict.insert Opt.toComparableGlobal (Opt.Global home name) node nodes + + + +-- ALIAS + + +addAliases : IO.Canonical -> Dict String Name.Name Can.Alias -> Opt.LocalGraph -> Opt.LocalGraph +addAliases home aliases graph = + Dict.foldr compare (addAlias home) graph aliases + + +addAlias : IO.Canonical -> Name.Name -> Can.Alias -> Opt.LocalGraph -> Opt.LocalGraph +addAlias home name (Can.Alias _ tipe) ((Opt.LocalGraph main nodes fieldCounts) as graph) = + case tipe of + Can.TRecord fields Nothing -> + let + function : Opt.Expr + function = + Opt.Function (List.map Tuple.first (Can.fieldsToList fields)) <| + Opt.Record <| + Dict.map (\field _ -> Opt.VarLocal field) fields + + node : Opt.Node + node = + Opt.Define function EverySet.empty + in + Opt.LocalGraph + main + (Dict.insert Opt.toComparableGlobal (Opt.Global home name) node nodes) + (Dict.foldr compare addRecordCtorField fieldCounts fields) + + _ -> + graph + + +addRecordCtorField : Name.Name -> Can.FieldType -> Dict String Name.Name Int -> Dict String Name.Name Int +addRecordCtorField name _ fields = + Utils.mapInsertWith identity (+) name 1 fields + + + +-- ADD EFFECTS + + +addEffects : IO.Canonical -> Can.Effects -> Opt.LocalGraph -> Opt.LocalGraph +addEffects home effects ((Opt.LocalGraph main nodes fields) as graph) = + case effects of + Can.NoEffects -> + graph + + Can.Ports ports -> + Dict.foldr compare (addPort home) graph ports + + Can.Manager _ _ _ manager -> + let + fx : Opt.Global + fx = + Opt.Global home "$fx$" + + cmd : Opt.Global + cmd = + Opt.Global home "command" + + sub : Opt.Global + sub = + Opt.Global home "subscription" + + link : Opt.Node + link = + Opt.Link fx + + newNodes : Dict (List String) Opt.Global Opt.Node + newNodes = + case manager of + Can.Cmd _ -> + Dict.insert Opt.toComparableGlobal cmd link <| + Dict.insert Opt.toComparableGlobal fx (Opt.Manager Opt.Cmd) nodes + + Can.Sub _ -> + Dict.insert Opt.toComparableGlobal sub link <| + Dict.insert Opt.toComparableGlobal fx (Opt.Manager Opt.Sub) nodes + + Can.Fx _ _ -> + Dict.insert Opt.toComparableGlobal cmd link <| + Dict.insert Opt.toComparableGlobal sub link <| + Dict.insert Opt.toComparableGlobal fx (Opt.Manager Opt.Fx) nodes + in + Opt.LocalGraph main newNodes fields + + +addPort : IO.Canonical -> Name.Name -> Can.Port -> Opt.LocalGraph -> Opt.LocalGraph +addPort home name port_ graph = + case port_ of + Can.Incoming { payload } -> + let + ( deps, fields, decoder ) = + Names.run (Port.toDecoder payload) + + node : Opt.Node + node = + Opt.PortIncoming decoder deps + in + addToGraph (Opt.Global home name) node fields graph + + Can.Outgoing { payload } -> + let + ( deps, fields, encoder ) = + Names.run (Port.toEncoder payload) + + node : Opt.Node + node = + Opt.PortOutgoing encoder deps + in + addToGraph (Opt.Global home name) node fields graph + + + +-- HELPER + + +addToGraph : Opt.Global -> Opt.Node -> Dict String Name.Name Int -> Opt.LocalGraph -> Opt.LocalGraph +addToGraph name node fields (Opt.LocalGraph main nodes fieldCounts) = + Opt.LocalGraph + main + (Dict.insert Opt.toComparableGlobal name node nodes) + (Utils.mapUnionWith identity compare (+) fields fieldCounts) + + + +-- ADD DECLS + + +addDecls : IO.Canonical -> Annotations -> Can.Decls -> Opt.LocalGraph -> MResult i (List W.Warning) Opt.LocalGraph +addDecls home annotations decls graph = + R.loop (addDeclsHelp home annotations) ( decls, graph ) + + +addDeclsHelp : IO.Canonical -> Annotations -> ( Can.Decls, Opt.LocalGraph ) -> MResult i (List W.Warning) (R.Step ( Can.Decls, Opt.LocalGraph ) Opt.LocalGraph) +addDeclsHelp home annotations ( decls, graph ) = + case decls of + Can.Declare def subDecls -> + addDef home annotations def graph + |> R.fmap (R.Loop << Tuple.pair subDecls) + + Can.DeclareRec d ds subDecls -> + let + defs : List Can.Def + defs = + d :: ds + in + case findMain defs of + Nothing -> + R.pure (R.Loop ( subDecls, addRecDefs home defs graph )) + + Just region -> + R.throw <| E.BadCycle region (defToName d) (List.map defToName ds) + + Can.SaveTheEnvironment -> + R.ok (R.Done graph) + + +findMain : List Can.Def -> Maybe A.Region +findMain defs = + case defs of + [] -> + Nothing + + def :: rest -> + case def of + Can.Def (A.At region name) _ _ -> + if name == Name.main_ then + Just region + + else + findMain rest + + Can.TypedDef (A.At region name) _ _ _ _ -> + if name == Name.main_ then + Just region + + else + findMain rest + + +defToName : Can.Def -> Name.Name +defToName def = + case def of + Can.Def (A.At _ name) _ _ -> + name + + Can.TypedDef (A.At _ name) _ _ _ _ -> + name + + + +-- ADD DEFS + + +addDef : IO.Canonical -> Annotations -> Can.Def -> Opt.LocalGraph -> MResult i (List W.Warning) Opt.LocalGraph +addDef home annotations def graph = + case def of + Can.Def (A.At region name) args body -> + let + (Can.Forall _ tipe) = + Utils.find identity name annotations + in + R.warn (W.MissingTypeAnnotation region name tipe) + |> R.bind (\_ -> addDefHelp region annotations home name args body graph) + + Can.TypedDef (A.At region name) _ typedArgs body _ -> + addDefHelp region annotations home name (List.map Tuple.first typedArgs) body graph + + +addDefHelp : A.Region -> Annotations -> IO.Canonical -> Name.Name -> List Can.Pattern -> Can.Expr -> Opt.LocalGraph -> MResult i w Opt.LocalGraph +addDefHelp region annotations home name args body ((Opt.LocalGraph _ nodes fieldCounts) as graph) = + if name /= Name.main_ then + R.ok (addDefNode home region name args body EverySet.empty graph) + + else + let + (Can.Forall _ tipe) = + Utils.find identity name annotations + + addMain : ( EverySet (List String) Opt.Global, Dict String Name.Name Int, Opt.Main ) -> Opt.LocalGraph + addMain ( deps, fields, main ) = + addDefNode home region name args body deps <| + Opt.LocalGraph (Just main) nodes (Utils.mapUnionWith identity compare (+) fields fieldCounts) + in + case Type.deepDealias tipe of + Can.TType hm nm [ _ ] -> + if hm == ModuleName.virtualDom && nm == Name.node then + R.ok <| addMain <| Names.run <| Names.registerKernel Name.virtualDom Opt.Static + + else + R.throw (E.BadType region tipe) + + Can.TType hm nm [ flags, _, message ] -> + if hm == ModuleName.platform && nm == Name.program then + case Effects.checkPayload flags of + Ok () -> + R.ok <| addMain <| Names.run <| Names.fmap (Opt.Dynamic message) <| Port.toFlagsDecoder flags + + Err ( subType, invalidPayload ) -> + R.throw (E.BadFlags region subType invalidPayload) + + else + R.throw (E.BadType region tipe) + + _ -> + R.throw (E.BadType region tipe) + + +addDefNode : IO.Canonical -> A.Region -> Name.Name -> List Can.Pattern -> Can.Expr -> EverySet (List String) Opt.Global -> Opt.LocalGraph -> Opt.LocalGraph +addDefNode home region name args body mainDeps graph = + let + ( deps, fields, def ) = + Names.run <| + case args of + [] -> + Expr.optimize EverySet.empty body + + _ -> + Expr.destructArgs args + |> Names.bind + (\( argNames, destructors ) -> + Expr.optimize EverySet.empty body + |> Names.fmap + (\obody -> + Opt.TrackedFunction argNames <| + List.foldr Opt.Destruct obody destructors + ) + ) + in + addToGraph (Opt.Global home name) (Opt.TrackedDefine region def (EverySet.union deps mainDeps)) fields graph + + + +-- ADD RECURSIVE DEFS + + +type State + = State + { values : List ( Name.Name, Opt.Expr ) + , functions : List Opt.Def + } + + +addRecDefs : IO.Canonical -> List Can.Def -> Opt.LocalGraph -> Opt.LocalGraph +addRecDefs home defs (Opt.LocalGraph main nodes fieldCounts) = + let + names : List Name.Name + names = + List.reverse (List.map toName defs) + + cycleName : Opt.Global + cycleName = + Opt.Global home (Name.fromManyNames names) + + cycle : EverySet String Name.Name + cycle = + List.foldr addValueName EverySet.empty defs + + links : Dict (List String) Opt.Global Opt.Node + links = + List.foldr (addLink home (Opt.Link cycleName)) Dict.empty defs + + ( deps, fields, State { values, functions } ) = + Names.run <| + List.foldl (\def -> Names.bind (\state -> addRecDef cycle state def)) + (Names.pure (State { values = [], functions = [] })) + defs + in + Opt.LocalGraph + main + (Dict.insert Opt.toComparableGlobal cycleName (Opt.Cycle names values functions deps) (Dict.union links nodes)) + (Utils.mapUnionWith identity compare (+) fields fieldCounts) + + +toName : Can.Def -> Name.Name +toName def = + case def of + Can.Def (A.At _ name) _ _ -> + name + + Can.TypedDef (A.At _ name) _ _ _ _ -> + name + + +addValueName : Can.Def -> EverySet String Name.Name -> EverySet String Name.Name +addValueName def names = + case def of + Can.Def (A.At _ name) args _ -> + if List.isEmpty args then + EverySet.insert identity name names + + else + names + + Can.TypedDef (A.At _ name) _ args _ _ -> + if List.isEmpty args then + EverySet.insert identity name names + + else + names + + +addLink : IO.Canonical -> Opt.Node -> Can.Def -> Dict (List String) Opt.Global Opt.Node -> Dict (List String) Opt.Global Opt.Node +addLink home link def links = + case def of + Can.Def (A.At _ name) _ _ -> + Dict.insert Opt.toComparableGlobal (Opt.Global home name) link links + + Can.TypedDef (A.At _ name) _ _ _ _ -> + Dict.insert Opt.toComparableGlobal (Opt.Global home name) link links + + + +-- ADD RECURSIVE DEFS + + +addRecDef : EverySet String Name.Name -> State -> Can.Def -> Names.Tracker State +addRecDef cycle state def = + case def of + Can.Def (A.At region name) args body -> + addRecDefHelp cycle region state name args body + + Can.TypedDef (A.At region name) _ args body _ -> + addRecDefHelp cycle region state name (List.map Tuple.first args) body + + +addRecDefHelp : EverySet String Name.Name -> A.Region -> State -> Name.Name -> List Can.Pattern -> Can.Expr -> Names.Tracker State +addRecDefHelp cycle region (State { values, functions }) name args body = + case args of + [] -> + Expr.optimize cycle body + |> Names.fmap + (\obody -> + State + { values = ( name, obody ) :: values + , functions = functions + } + ) + + _ :: _ -> + Expr.optimizePotentialTailCall cycle region name args body + |> Names.fmap + (\odef -> + State + { values = values + , functions = odef :: functions + } + ) diff --git a/src/Compiler/Optimize/Names.elm b/src/Compiler/Optimize/Names.elm new file mode 100644 index 0000000000..f0ef23a557 --- /dev/null +++ b/src/Compiler/Optimize/Names.elm @@ -0,0 +1,209 @@ +module Compiler.Optimize.Names exposing + ( Tracker + , bind + , fmap + , generate + , mapTraverse + , pure + , registerCtor + , registerDebug + , registerField + , registerFieldDict + , registerFieldList + , registerGlobal + , registerKernel + , run + , traverse + ) + +import Compiler.AST.Canonical as Can +import Compiler.AST.Optimized as Opt +import Compiler.Data.Index as Index +import Compiler.Data.Name as Name exposing (Name) +import Compiler.Elm.ModuleName as ModuleName +import Compiler.Reporting.Annotation as A +import Data.Map as Dict exposing (Dict) +import Data.Set as EverySet exposing (EverySet) +import System.TypeCheck.IO as IO +import Utils.Main as Utils + + + +-- GENERATOR + + +type Tracker a + = Tracker + (Int + -> EverySet (List String) Opt.Global + -> Dict String Name Int + -> TResult a + ) + + +type TResult a + = TResult Int (EverySet (List String) Opt.Global) (Dict String Name Int) a + + +run : Tracker a -> ( EverySet (List String) Opt.Global, Dict String Name Int, a ) +run (Tracker k) = + case k 0 EverySet.empty Dict.empty of + TResult _ deps fields value -> + ( deps, fields, value ) + + +generate : Tracker Name +generate = + Tracker <| + \uid deps fields -> + TResult (uid + 1) deps fields (Name.fromVarIndex uid) + + +registerKernel : Name -> a -> Tracker a +registerKernel home value = + Tracker <| + \uid deps fields -> + TResult uid (EverySet.insert Opt.toComparableGlobal (Opt.toKernelGlobal home) deps) fields value + + +registerGlobal : A.Region -> IO.Canonical -> Name -> Tracker Opt.Expr +registerGlobal region home name = + Tracker <| + \uid deps fields -> + let + global : Opt.Global + global = + Opt.Global home name + in + TResult uid (EverySet.insert Opt.toComparableGlobal global deps) fields (Opt.VarGlobal region global) + + +registerDebug : Name -> IO.Canonical -> A.Region -> Tracker Opt.Expr +registerDebug name home region = + Tracker <| + \uid deps fields -> + let + global : Opt.Global + global = + Opt.Global ModuleName.debug name + in + TResult uid (EverySet.insert Opt.toComparableGlobal global deps) fields (Opt.VarDebug region name home Nothing) + + +registerCtor : A.Region -> IO.Canonical -> A.Located Name -> Index.ZeroBased -> Can.CtorOpts -> Tracker Opt.Expr +registerCtor region home (A.At _ name) index opts = + Tracker <| + \uid deps fields -> + let + global : Opt.Global + global = + Opt.Global home name + + newDeps : EverySet (List String) Opt.Global + newDeps = + EverySet.insert Opt.toComparableGlobal global deps + in + case opts of + Can.Normal -> + TResult uid newDeps fields (Opt.VarGlobal region global) + + Can.Enum -> + TResult uid newDeps fields <| + case name of + "True" -> + if home == ModuleName.basics then + Opt.Bool region True + + else + Opt.VarEnum region global index + + "False" -> + if home == ModuleName.basics then + Opt.Bool region False + + else + Opt.VarEnum region global index + + _ -> + Opt.VarEnum region global index + + Can.Unbox -> + TResult uid (EverySet.insert Opt.toComparableGlobal identity newDeps) fields (Opt.VarBox region global) + + +identity : Opt.Global +identity = + Opt.Global ModuleName.basics Name.identity_ + + +registerField : Name -> a -> Tracker a +registerField name value = + Tracker <| + \uid d fields -> + TResult uid d (Utils.mapInsertWith Basics.identity (+) name 1 fields) value + + +registerFieldDict : Dict String Name v -> a -> Tracker a +registerFieldDict newFields value = + Tracker <| + \uid d fields -> + TResult uid + d + (Utils.mapUnionWith Basics.identity compare (+) fields (Dict.map (\_ -> toOne) newFields)) + value + + +toOne : a -> Int +toOne _ = + 1 + + +registerFieldList : List Name -> a -> Tracker a +registerFieldList names value = + Tracker <| + \uid deps fields -> + TResult uid deps (List.foldr addOne fields names) value + + +addOne : Name -> Dict String Name Int -> Dict String Name Int +addOne name fields = + Utils.mapInsertWith Basics.identity (+) name 1 fields + + + +-- INSTANCES + + +fmap : (a -> b) -> Tracker a -> Tracker b +fmap func (Tracker kv) = + Tracker <| + \n d f -> + case kv n d f of + TResult n1 d1 f1 value -> + TResult n1 d1 f1 (func value) + + +pure : a -> Tracker a +pure value = + Tracker (\n d f -> TResult n d f value) + + +bind : (a -> Tracker b) -> Tracker a -> Tracker b +bind callback (Tracker k) = + Tracker <| + \n d f -> + case k n d f of + TResult n1 d1 f1 a -> + case callback a of + Tracker kb -> + kb n1 d1 f1 + + +traverse : (a -> Tracker b) -> List a -> Tracker (List b) +traverse func = + List.foldl (\a -> bind (\acc -> fmap (\b -> acc ++ [ b ]) (func a))) (pure []) + + +mapTraverse : (k -> comparable) -> (k -> k -> Order) -> (a -> Tracker b) -> Dict comparable k a -> Tracker (Dict comparable k b) +mapTraverse toComparable keyComparison func = + Dict.foldl keyComparison (\k a -> bind (\c -> fmap (\va -> Dict.insert toComparable k va c) (func a))) (pure Dict.empty) diff --git a/src/Compiler/Optimize/Port.elm b/src/Compiler/Optimize/Port.elm new file mode 100644 index 0000000000..62526af956 --- /dev/null +++ b/src/Compiler/Optimize/Port.elm @@ -0,0 +1,480 @@ +module Compiler.Optimize.Port exposing + ( toDecoder + , toEncoder + , toFlagsDecoder + ) + +import Basics.Extra exposing (flip) +import Compiler.AST.Canonical as Can +import Compiler.AST.Optimized as Opt +import Compiler.AST.Utils.Type as Type +import Compiler.Data.Index as Index +import Compiler.Data.Name as Name exposing (Name) +import Compiler.Elm.ModuleName as ModuleName +import Compiler.Generate.JavaScript.Name as JsName +import Compiler.Optimize.Names as Names +import Compiler.Reporting.Annotation as A +import Data.Map as Dict exposing (Dict) +import Utils.Crash exposing (crash) + + + +-- ENCODE + + +toEncoder : Can.Type -> Names.Tracker Opt.Expr +toEncoder tipe = + case tipe of + Can.TAlias _ _ args alias -> + toEncoder (Type.dealias args alias) + + Can.TLambda _ _ -> + crash "toEncoder: function" + + Can.TVar _ -> + crash "toEncoder: type variable" + + Can.TUnit -> + Names.fmap (Opt.Function [ Name.dollar ]) (encode "null") + + Can.TTuple a b cs -> + encodeTuple a b cs + + Can.TType _ name args -> + case args of + [] -> + if name == Name.float then + encode "float" + + else if name == Name.int then + encode "int" + + else if name == Name.bool then + encode "bool" + + else if name == Name.string then + encode "string" + + else if name == Name.value then + Names.registerGlobal A.zero ModuleName.basics Name.identity_ + + else + crash "toEncoder: bad custom type" + + [ arg ] -> + if name == Name.maybe then + encodeMaybe arg + + else if name == Name.list then + encodeList arg + + else if name == Name.array then + encodeArray arg + + else + crash "toEncoder: bad custom type" + + _ -> + crash "toEncoder: bad custom type" + + Can.TRecord _ (Just _) -> + crash "toEncoder: bad record" + + Can.TRecord fields Nothing -> + let + encodeField : ( Name, Can.FieldType ) -> Names.Tracker Opt.Expr + encodeField ( name, Can.FieldType _ fieldType ) = + toEncoder fieldType + |> Names.fmap + (\encoder -> + let + value : Opt.Expr + value = + Opt.Call A.zero encoder [ Opt.Access (Opt.VarLocal Name.dollar) A.zero name ] + in + Opt.Tuple A.zero (Opt.Str A.zero (Name.toElmString name)) value [] + ) + in + encode "object" + |> Names.bind + (\object -> + Names.traverse encodeField (Dict.toList compare fields) + |> Names.bind + (\keyValuePairs -> + Names.registerFieldDict fields + (Opt.Function [ Name.dollar ] (Opt.Call A.zero object [ Opt.List A.zero keyValuePairs ])) + ) + ) + + + +-- ENCODE HELPERS + + +encodeMaybe : Can.Type -> Names.Tracker Opt.Expr +encodeMaybe tipe = + encode "null" + |> Names.bind + (\null -> + toEncoder tipe + |> Names.bind + (\encoder -> + Names.registerGlobal A.zero ModuleName.maybe "destruct" + |> Names.fmap + (\destruct -> + Opt.Function [ Name.dollar ] + (Opt.Call A.zero + destruct + [ null + , encoder + , Opt.VarLocal Name.dollar + ] + ) + ) + ) + ) + + +encodeList : Can.Type -> Names.Tracker Opt.Expr +encodeList tipe = + encode "list" + |> Names.bind + (\list -> + toEncoder tipe + |> Names.fmap (Opt.Call A.zero list << List.singleton) + ) + + +encodeArray : Can.Type -> Names.Tracker Opt.Expr +encodeArray tipe = + encode "array" + |> Names.bind + (\array -> + toEncoder tipe + |> Names.fmap (Opt.Call A.zero array << List.singleton) + ) + + +encodeTuple : Can.Type -> Can.Type -> List Can.Type -> Names.Tracker Opt.Expr +encodeTuple a b cs = + let + let_ : Name -> Index.ZeroBased -> Opt.Expr -> Opt.Expr + let_ arg index body = + Opt.Destruct (Opt.Destructor arg (Opt.Index index (Opt.Root Name.dollar))) body + + letCs_ : Name -> Int -> Opt.Expr -> Opt.Expr + letCs_ arg index body = + Opt.Destruct (Opt.Destructor arg (Opt.ArrayIndex index (Opt.Field "cs" (Opt.Root Name.dollar)))) body + + encodeArg : Name -> Can.Type -> Names.Tracker Opt.Expr + encodeArg arg tipe = + toEncoder tipe + |> Names.fmap (\encoder -> Opt.Call A.zero encoder [ Opt.VarLocal arg ]) + in + encode "list" + |> Names.bind + (\list -> + Names.registerGlobal A.zero ModuleName.basics Name.identity_ + |> Names.bind + (\identity -> + Names.bind + (\arg1 -> + Names.bind + (\arg2 -> + let + ( _, indexedCs ) = + List.foldl (\( i, c ) ( index, acc ) -> ( Index.next index, ( i, index, c ) :: acc )) + ( Index.third, [] ) + (List.indexedMap Tuple.pair cs) + |> Tuple.mapSecond List.reverse + in + List.foldl + (\( _, i, tipe ) acc -> + Names.bind (\encodedArg -> Names.fmap (flip (++) [ encodedArg ]) acc) + (encodeArg (JsName.fromIndex i) tipe) + ) + (Names.pure [ arg1, arg2 ]) + indexedCs + |> Names.fmap + (\args -> + Opt.Function [ Name.dollar ] + (let_ "a" + Index.first + (let_ "b" + Index.second + (List.foldr (\( i, index, _ ) -> letCs_ (JsName.fromIndex index) i) + (Opt.Call A.zero list [ identity, Opt.List A.zero args ]) + indexedCs + ) + ) + ) + ) + ) + (encodeArg "b" b) + ) + (encodeArg "a" a) + ) + ) + + + +-- FLAGS DECODER + + +toFlagsDecoder : Can.Type -> Names.Tracker Opt.Expr +toFlagsDecoder tipe = + case tipe of + Can.TUnit -> + Names.fmap (\succeed -> Opt.Call A.zero succeed [ Opt.Unit ]) + (decode "succeed") + + _ -> + toDecoder tipe + + + +-- DECODE + + +toDecoder : Can.Type -> Names.Tracker Opt.Expr +toDecoder tipe = + case tipe of + Can.TLambda _ _ -> + crash "functions should not be allowed through input ports" + + Can.TVar _ -> + crash "type variables should not be allowed through input ports" + + Can.TAlias _ _ args alias -> + toDecoder (Type.dealias args alias) + + Can.TUnit -> + decodeTuple0 + + Can.TTuple a b cs -> + decodeTuple a b cs + + Can.TType _ name args -> + case ( name, args ) of + ( "Float", [] ) -> + decode "float" + + ( "Int", [] ) -> + decode "int" + + ( "Bool", [] ) -> + decode "bool" + + ( "String", [] ) -> + decode "string" + + ( "Value", [] ) -> + decode "value" + + ( "Maybe", [ arg ] ) -> + decodeMaybe arg + + ( "List", [ arg ] ) -> + decodeList arg + + ( "Array", [ arg ] ) -> + decodeArray arg + + _ -> + crash "toDecoder: bad type" + + Can.TRecord _ (Just _) -> + crash "toDecoder: bad record" + + Can.TRecord fields Nothing -> + decodeRecord fields + + + +-- DECODE MAYBE + + +decodeMaybe : Can.Type -> Names.Tracker Opt.Expr +decodeMaybe tipe = + Names.bind + (\nothing -> + Names.bind + (\just -> + Names.bind + (\oneOf -> + Names.bind + (\null -> + Names.bind + (\map_ -> + Names.fmap + (\subDecoder -> + Opt.Call A.zero + oneOf + [ Opt.List A.zero + [ Opt.Call A.zero null [ nothing ] + , Opt.Call A.zero map_ [ just, subDecoder ] + ] + ] + ) + (toDecoder tipe) + ) + (decode "map") + ) + (decode "null") + ) + (decode "oneOf") + ) + (Names.registerGlobal A.zero ModuleName.maybe "Just") + ) + (Names.registerGlobal A.zero ModuleName.maybe "Nothing") + + + +-- DECODE LIST + + +decodeList : Can.Type -> Names.Tracker Opt.Expr +decodeList tipe = + Names.bind + (\list -> + Names.fmap (Opt.Call A.zero list << List.singleton) + (toDecoder tipe) + ) + (decode "list") + + + +-- DECODE ARRAY + + +decodeArray : Can.Type -> Names.Tracker Opt.Expr +decodeArray tipe = + Names.bind + (\array -> + Names.fmap (Opt.Call A.zero array << List.singleton) + (toDecoder tipe) + ) + (decode "array") + + + +-- DECODE TUPLES + + +decodeTuple0 : Names.Tracker Opt.Expr +decodeTuple0 = + Names.fmap (\null -> Opt.Call A.zero null [ Opt.Unit ]) + (decode "null") + + +decodeTuple : Can.Type -> Can.Type -> List Can.Type -> Names.Tracker Opt.Expr +decodeTuple a b cs = + Names.bind + (\succeed -> + let + ( allElems, lastElem ) = + case List.reverse cs of + c :: rest -> + ( a :: b :: List.reverse rest, c ) + + _ -> + ( [ a ], b ) + + tuple : Opt.Expr + tuple = + Opt.Tuple A.zero (toLocal 0) (toLocal 1) (List.indexedMap (\i _ -> toLocal (i + 2)) cs) + in + List.foldr (\( i, c ) -> Names.bind (indexAndThen i c)) + (indexAndThen (List.length cs + 1) lastElem (Opt.Call A.zero succeed [ tuple ])) + (List.indexedMap Tuple.pair allElems) + ) + (decode "succeed") + + +toLocal : Int -> Opt.Expr +toLocal index = + Opt.VarLocal (Name.fromVarIndex index) + + +indexAndThen : Int -> Can.Type -> Opt.Expr -> Names.Tracker Opt.Expr +indexAndThen i tipe decoder = + Names.bind + (\andThen -> + Names.bind + (\index -> + Names.fmap + (\typeDecoder -> + Opt.Call A.zero + andThen + [ Opt.Function [ Name.fromVarIndex i ] decoder + , Opt.Call A.zero index [ Opt.Int A.zero i, typeDecoder ] + ] + ) + (toDecoder tipe) + ) + (decode "index") + ) + (decode "andThen") + + + +-- DECODE RECORDS + + +decodeRecord : Dict String Name.Name Can.FieldType -> Names.Tracker Opt.Expr +decodeRecord fields = + let + toFieldExpr : Name -> b -> Opt.Expr + toFieldExpr name _ = + Opt.VarLocal name + + record : Opt.Expr + record = + Opt.Record (Dict.map toFieldExpr fields) + in + Names.bind + (\succeed -> + Names.registerFieldDict fields (Dict.toList compare fields) + |> Names.bind + (\fieldDecoders -> + List.foldl (\fieldDecoder -> Names.bind (\optCall -> fieldAndThen optCall fieldDecoder)) + (Names.pure (Opt.Call A.zero succeed [ record ])) + fieldDecoders + ) + ) + (decode "succeed") + + +fieldAndThen : Opt.Expr -> ( Name.Name, Can.FieldType ) -> Names.Tracker Opt.Expr +fieldAndThen decoder ( key, Can.FieldType _ tipe ) = + Names.bind + (\andThen -> + Names.bind + (\field -> + Names.fmap + (\typeDecoder -> + Opt.Call A.zero + andThen + [ Opt.Function [ key ] decoder + , Opt.Call A.zero field [ Opt.Str A.zero (Name.toElmString key), typeDecoder ] + ] + ) + (toDecoder tipe) + ) + (decode "field") + ) + (decode "andThen") + + + +-- GLOBALS HELPERS + + +encode : Name -> Names.Tracker Opt.Expr +encode name = + Names.registerGlobal A.zero ModuleName.jsonEncode name + + +decode : Name -> Names.Tracker Opt.Expr +decode name = + Names.registerGlobal A.zero ModuleName.jsonDecode name diff --git a/src/Compiler/Parse/Declaration.elm b/src/Compiler/Parse/Declaration.elm new file mode 100644 index 0000000000..e3ed23db62 --- /dev/null +++ b/src/Compiler/Parse/Declaration.elm @@ -0,0 +1,423 @@ +module Compiler.Parse.Declaration exposing + ( Decl(..) + , declaration + , infix_ + ) + +import Compiler.AST.Source as Src +import Compiler.AST.Utils.Binop as Binop +import Compiler.Data.Name exposing (Name) +import Compiler.Parse.Expression as Expr +import Compiler.Parse.Keyword as Keyword +import Compiler.Parse.Number as Number +import Compiler.Parse.Pattern as Pattern +import Compiler.Parse.Primitives as P +import Compiler.Parse.Space as Space +import Compiler.Parse.Symbol as Symbol +import Compiler.Parse.SyntaxVersion exposing (SyntaxVersion) +import Compiler.Parse.Type as Type +import Compiler.Parse.Variable as Var +import Compiler.Reporting.Annotation as A +import Compiler.Reporting.Error.Syntax as E + + + +-- DECLARATION + + +type Decl + = Value (Maybe Src.Comment) (A.Located Src.Value) + | Union (Maybe Src.Comment) (A.Located Src.Union) + | Alias (Maybe Src.Comment) (A.Located Src.Alias) + | Port (Maybe Src.Comment) Src.Port + + +declaration : SyntaxVersion -> Space.Parser E.Decl (Src.C2 Decl) +declaration syntaxVersion = + chompDocComment + |> P.bind + (\( docComments, maybeDocs ) -> + P.getPosition + |> P.bind + (\start -> + P.oneOf E.DeclStart + [ typeDecl maybeDocs start + , portDecl maybeDocs + , valueDecl syntaxVersion maybeDocs docComments start + ] + ) + ) + + + +-- DOC COMMENT + + +chompDocComment : P.Parser E.Decl (Src.C1 (Maybe Src.Comment)) +chompDocComment = + P.oneOfWithFallback + [ Space.docComment E.DeclStart E.DeclSpace + |> P.bind + (\docComment -> + Space.chomp E.DeclSpace + |> P.bind + (\comments -> + Space.checkFreshLine E.DeclFreshLineAfterDocComment + |> P.fmap (\_ -> ( comments, Just docComment )) + ) + ) + ] + ( [], Nothing ) + + + +-- DEFINITION and ANNOTATION + + +valueDecl : SyntaxVersion -> Maybe Src.Comment -> Src.FComments -> A.Position -> Space.Parser E.Decl (Src.C2 Decl) +valueDecl syntaxVersion maybeDocs docComments start = + Var.lower E.DeclStart + |> P.bind + (\name -> + P.getPosition + |> P.bind + (\end -> + P.specialize (E.DeclDef name) <| + (Space.chompAndCheckIndent E.DeclDefSpace E.DeclDefIndentEquals + |> P.bind + (\postNameComments -> + P.oneOf E.DeclDefEquals + [ P.word1 ':' E.DeclDefEquals + |> P.bind (\_ -> Space.chompAndCheckIndent E.DeclDefSpace E.DeclDefIndentType) + |> P.bind + (\preTypeComments -> + P.specialize E.DeclDefType (Type.expression preTypeComments) + |> P.bind + (\( ( ( preTipeComments, postTipeComments, _ ), tipe ), _ ) -> + Space.checkFreshLine E.DeclDefNameRepeat + |> P.bind (\_ -> chompMatchingName name) + |> P.bind + (\defName -> + Space.chompAndCheckIndent E.DeclDefSpace E.DeclDefIndentEquals + |> P.bind + (\preArgComments -> + chompDefArgsAndBody syntaxVersion maybeDocs docComments start defName (Just ( postTipeComments, ( ( postNameComments, preTipeComments ), tipe ) )) preArgComments [] + ) + ) + ) + ) + , chompDefArgsAndBody syntaxVersion maybeDocs docComments start (A.at start end name) Nothing postNameComments [] + ] + ) + ) + ) + ) + + +chompDefArgsAndBody : SyntaxVersion -> Maybe Src.Comment -> Src.FComments -> A.Position -> A.Located Name -> Maybe (Src.C1 (Src.C2 Src.Type)) -> Src.FComments -> List (Src.C1 Src.Pattern) -> Space.Parser E.DeclDef (Src.C2 Decl) +chompDefArgsAndBody syntaxVersion maybeDocs docComments start name tipe preArgComments revArgs = + P.oneOf E.DeclDefEquals + [ P.specialize E.DeclDefArg (Pattern.term syntaxVersion) + |> P.bind + (\arg -> + Space.chompAndCheckIndent E.DeclDefSpace E.DeclDefIndentEquals + |> P.bind + (\postArgComments -> + chompDefArgsAndBody syntaxVersion maybeDocs docComments start name tipe postArgComments (( preArgComments, arg ) :: revArgs) + ) + ) + , P.word1 '=' E.DeclDefEquals + |> P.bind (\_ -> Space.chompAndCheckIndent E.DeclDefSpace E.DeclDefIndentBody) + |> P.bind + (\preBodyComments -> + P.specialize E.DeclDefBody (Expr.expression syntaxVersion) + |> P.fmap + (\( ( trailingComments, body ), end ) -> + let + value : Src.Value + value = + Src.Value docComments ( preArgComments, name ) (List.reverse revArgs) ( preBodyComments, body ) tipe + + avalue : A.Located Src.Value + avalue = + A.at start end value + in + ( ( ( [], trailingComments ), Value maybeDocs avalue ), end ) + ) + ) + ] + + +chompMatchingName : Name -> P.Parser E.DeclDef (A.Located Name) +chompMatchingName expectedName = + let + (P.Parser parserL) = + Var.lower E.DeclDefNameRepeat + in + P.Parser <| + \((P.State _ _ _ _ sr sc) as state) -> + case parserL state of + P.Cok name ((P.State _ _ _ _ er ec) as newState) -> + if expectedName == name then + P.Cok (A.At (A.Region (A.Position sr sc) (A.Position er ec)) name) newState + + else + P.Cerr sr sc (E.DeclDefNameMatch name) + + P.Eok name ((P.State _ _ _ _ er ec) as newState) -> + if expectedName == name then + P.Eok (A.At (A.Region (A.Position sr sc) (A.Position er ec)) name) newState + + else + P.Eerr sr sc (E.DeclDefNameMatch name) + + P.Cerr r c t -> + P.Cerr r c t + + P.Eerr r c t -> + P.Eerr r c t + + + +-- TYPE DECLARATIONS + + +typeDecl : Maybe Src.Comment -> A.Position -> Space.Parser E.Decl (Src.C2 Decl) +typeDecl maybeDocs start = + P.inContext E.DeclType (Keyword.type_ E.DeclStart) <| + (Space.chompAndCheckIndent E.DT_Space E.DT_IndentName + |> P.bind + (\postTypeComments -> + P.oneOf E.DT_Name + [ P.inContext E.DT_Alias (Keyword.alias_ E.DT_Name) <| + (Space.chompAndCheckIndent E.AliasSpace E.AliasIndentEquals + |> P.bind + (\preComments -> + chompAliasNameToEquals + |> P.bind + (\( ( name, args, postComments ), preTypeComments ) -> + P.specialize E.AliasBody (Type.expression []) + |> P.fmap + (\( ( _, tipe ), end ) -> + let + alias_ : A.Located Src.Alias + alias_ = + A.at start end (Src.Alias postTypeComments ( ( preComments, postComments ), name ) args ( preTypeComments, tipe )) + in + ( ( ( [], [] ), Alias maybeDocs alias_ ), end ) + ) + ) + ) + ) + , P.specialize E.DT_Union <| + (chompCustomNameToEquals postTypeComments + |> P.bind + (\( preVariantsComments, ( name, args ) ) -> + Type.variant preVariantsComments + |> P.bind + (\( firstVariant, firstEnd ) -> + chompVariants [ firstVariant ] firstEnd + |> P.fmap + (\( variants, end ) -> + let + union : A.Located Src.Union + union = + A.at start end (Src.Union name args variants) + in + ( ( ( [], [] ), Union maybeDocs union ), end ) + ) + ) + ) + ) + ] + ) + ) + + + +-- TYPE ALIASES + + +chompAliasNameToEquals : P.Parser E.TypeAlias ( ( A.Located Name, List (Src.C1 (A.Located Name)), Src.FComments ), Src.FComments ) +chompAliasNameToEquals = + P.addLocation (Var.upper E.AliasName) + |> P.bind + (\name -> + Space.chompAndCheckIndent E.AliasSpace E.AliasIndentEquals + |> P.bind + (\comments -> + chompAliasNameToEqualsHelp name [] comments + ) + ) + + +chompAliasNameToEqualsHelp : A.Located Name -> List (Src.C1 (A.Located Name)) -> Src.FComments -> P.Parser E.TypeAlias ( ( A.Located Name, List (Src.C1 (A.Located Name)), Src.FComments ), Src.FComments ) +chompAliasNameToEqualsHelp name args comments = + P.oneOf E.AliasEquals + [ P.addLocation (Var.lower E.AliasEquals) + |> P.bind + (\arg -> + Space.chompAndCheckIndent E.AliasSpace E.AliasIndentEquals + |> P.bind + (\postComments -> + chompAliasNameToEqualsHelp name (( comments, arg ) :: args) postComments + ) + ) + , P.word1 '=' E.AliasEquals + |> P.bind (\_ -> Space.chompAndCheckIndent E.AliasSpace E.AliasIndentBody) + |> P.fmap (\preBodyComments -> ( ( name, List.reverse args, comments ), preBodyComments )) + ] + + + +-- CUSTOM TYPES + + +chompCustomNameToEquals : Src.FComments -> P.Parser E.CustomType (Src.C1 ( Src.C2 (A.Located Name), List (Src.C1 (A.Located Name)) )) +chompCustomNameToEquals preNameComments = + P.addLocation (Var.upper E.CT_Name) + |> P.bind + (\name -> + Space.chompAndCheckIndent E.CT_Space E.CT_IndentEquals + |> P.bind (\trailingComments -> chompCustomNameToEqualsHelp trailingComments ( preNameComments, name ) []) + ) + + +chompCustomNameToEqualsHelp : Src.FComments -> Src.C1 (A.Located Name) -> List (Src.C1 (A.Located Name)) -> P.Parser E.CustomType (Src.C1 ( Src.C2 (A.Located Name), List (Src.C1 (A.Located Name)) )) +chompCustomNameToEqualsHelp trailingComments (( preNameComments, name_ ) as name) args = + P.oneOf E.CT_Equals + [ P.addLocation (Var.lower E.CT_Equals) + |> P.bind + (\arg -> + Space.chompAndCheckIndent E.CT_Space E.CT_IndentEquals + |> P.bind (\postArgComments -> chompCustomNameToEqualsHelp postArgComments name (( trailingComments, arg ) :: args)) + ) + , P.word1 '=' E.CT_Equals + |> P.bind (\_ -> Space.chompAndCheckIndent E.CT_Space E.CT_IndentAfterEquals) + |> P.fmap (\postEqualComments -> ( postEqualComments, ( ( ( preNameComments, trailingComments ), name_ ), List.reverse args ) )) + ] + + +chompVariants : List (Src.C2Eol ( A.Located Name, List (Src.C1 Src.Type) )) -> A.Position -> Space.Parser E.CustomType (List (Src.C2Eol ( A.Located Name, List (Src.C1 Src.Type) ))) +chompVariants variants end = + P.oneOfWithFallback + [ Space.checkIndent end E.CT_IndentBar + |> P.bind (\_ -> P.word1 '|' E.CT_Bar) + |> P.bind (\_ -> Space.chompAndCheckIndent E.CT_Space E.CT_IndentAfterBar) + |> P.bind (\preTypeComments -> Type.variant preTypeComments) + |> P.bind (\( variant, newEnd ) -> chompVariants (variant :: variants) newEnd) + ] + ( List.reverse variants, end ) + + + +-- PORT + + +portDecl : Maybe Src.Comment -> Space.Parser E.Decl (Src.C2 Decl) +portDecl maybeDocs = + P.inContext E.Port (Keyword.port_ E.DeclStart) <| + (Space.chompAndCheckIndent E.PortSpace E.PortIndentName + |> P.bind + (\preNameComments -> + P.addLocation (Var.lower E.PortName) + |> P.bind + (\name -> + Space.chompAndCheckIndent E.PortSpace E.PortIndentColon + |> P.bind + (\postNameComments -> + P.word1 ':' E.PortColon + |> P.bind (\_ -> Space.chompAndCheckIndent E.PortSpace E.PortIndentType) + |> P.bind + (\typeComments -> + P.specialize E.PortType (Type.expression []) + |> P.fmap + (\( ( ( preTipeComments, postTipeComments, _ ), tipe ), end ) -> + ( ( ( preTipeComments, postTipeComments ), Port maybeDocs (Src.Port typeComments ( ( preNameComments, postNameComments ), name ) tipe) ) + , end + ) + ) + ) + ) + ) + ) + ) + + + +-- INFIX +-- INVARIANT: always chomps to a freshline +-- + + +infix_ : P.Parser E.Module (Src.C1 (A.Located Src.Infix)) +infix_ = + let + err : P.Row -> P.Col -> E.Module + err = + E.Infix + + err_ : a -> P.Row -> P.Col -> E.Module + err_ = + \_ -> E.Infix + in + P.getPosition + |> P.bind + (\start -> + Keyword.infix_ err + |> P.bind (\_ -> Space.chompAndCheckIndent err_ err) + |> P.bind + (\preBinopComments -> + P.oneOf err + [ Keyword.left_ err |> P.fmap (\_ -> Binop.Left) + , Keyword.right_ err |> P.fmap (\_ -> Binop.Right) + , Keyword.non_ err |> P.fmap (\_ -> Binop.Non) + ] + |> P.fmap (Tuple.pair preBinopComments) + ) + |> P.bind + (\associativity -> + Space.chompAndCheckIndent err_ err + |> P.bind + (\prePrecedenceComments -> + Number.precedence err + |> P.fmap (Tuple.pair prePrecedenceComments) + ) + |> P.bind + (\precedence -> + Space.chompAndCheckIndent err_ err + |> P.bind + (\preOpComments -> + P.word1 '(' err + |> P.bind (\_ -> Symbol.operator err err_) + |> P.bind + (\op -> + P.word1 ')' err + |> P.bind (\_ -> Space.chompAndCheckIndent err_ err) + |> P.bind + (\postOpComments -> + P.word1 '=' err + |> P.bind (\_ -> Space.chompAndCheckIndent err_ err) + |> P.bind + (\preNameComments -> + Var.lower err + |> P.bind + (\name -> + P.getPosition + |> P.bind + (\end -> + Space.chomp err_ + |> P.bind + (\comments -> + Space.checkFreshLine err + |> P.fmap (\_ -> ( comments, A.at start end (Src.Infix ( ( preOpComments, postOpComments ), op ) associativity precedence ( preNameComments, name )) )) + ) + ) + ) + ) + ) + ) + ) + ) + ) + ) diff --git a/src/Compiler/Parse/Expression.elm b/src/Compiler/Parse/Expression.elm new file mode 100644 index 0000000000..108b6ba19e --- /dev/null +++ b/src/Compiler/Parse/Expression.elm @@ -0,0 +1,1095 @@ +module Compiler.Parse.Expression exposing + ( expression + , record + ) + +import Compiler.AST.Source as Src +import Compiler.Data.Name as Name exposing (Name) +import Compiler.Parse.Keyword as Keyword +import Compiler.Parse.Number as Number +import Compiler.Parse.Pattern as Pattern +import Compiler.Parse.Primitives as P exposing (Col, Row) +import Compiler.Parse.Shader as Shader +import Compiler.Parse.Space as Space +import Compiler.Parse.String as String +import Compiler.Parse.Symbol as Symbol +import Compiler.Parse.SyntaxVersion as SV exposing (SyntaxVersion) +import Compiler.Parse.Type as Type +import Compiler.Parse.Variable as Var +import Compiler.Reporting.Annotation as A +import Compiler.Reporting.Error.Syntax as E + + + +-- TERMS + + +term : SyntaxVersion -> P.Parser E.Expr Src.Expr +term syntaxVersion = + P.getPosition + |> P.bind + (\start -> + P.oneOf E.Start + [ variable start |> P.bind (accessible start) + , string syntaxVersion start + , number syntaxVersion start + , Shader.shader start + , list syntaxVersion start + , record syntaxVersion start |> P.bind (accessible start) + , tuple syntaxVersion start |> P.bind (accessible start) + , accessor start + , character syntaxVersion start + ] + ) + + +string : SyntaxVersion -> A.Position -> P.Parser E.Expr Src.Expr +string syntaxVersion start = + String.string syntaxVersion E.Start E.String_ + |> P.bind (\( str, representation ) -> P.addEnd start (Src.Str str representation)) + + +character : SyntaxVersion -> A.Position -> P.Parser E.Expr Src.Expr +character syntaxVersion start = + String.character syntaxVersion E.Start E.Char + |> P.bind (\chr -> P.addEnd start (Src.Chr chr)) + + +number : SyntaxVersion -> A.Position -> P.Parser E.Expr Src.Expr +number syntaxVersion start = + Number.number syntaxVersion E.Start E.Number + |> P.bind + (\nmbr -> + P.addEnd start <| + case nmbr of + Number.Int int src -> + Src.Int int src + + Number.Float float src -> + Src.Float float src + ) + + +accessor : A.Position -> P.Parser E.Expr Src.Expr +accessor start = + P.word1 '.' E.Dot + |> P.bind (\_ -> Var.lower E.Access) + |> P.bind (\field -> P.addEnd start (Src.Accessor field)) + + +variable : A.Position -> P.Parser E.Expr Src.Expr +variable start = + Var.foreignAlpha E.Start + |> P.bind (\var -> P.addEnd start var) + + +accessible : A.Position -> Src.Expr -> P.Parser E.Expr Src.Expr +accessible start expr = + P.oneOfWithFallback + [ P.word1 '.' E.Dot + |> P.bind (\_ -> P.getPosition) + |> P.bind + (\pos -> + Var.lower E.Access + |> P.bind + (\field -> + P.getPosition + |> P.bind + (\end -> + accessible start <| + A.at start end (Src.Access expr (A.at pos end field)) + ) + ) + ) + ] + expr + + + +-- LISTS + + +list : SyntaxVersion -> A.Position -> P.Parser E.Expr Src.Expr +list syntaxVersion start = + P.inContext E.List (P.word1 '[' E.Start) <| + (Space.chompAndCheckIndent E.ListSpace E.ListIndentOpen + |> P.bind + (\comments -> + P.oneOf E.ListOpen + [ P.specialize E.ListExpr (expression syntaxVersion) + |> P.bind + (\( ( postEntryComments, entry ), end ) -> + Space.checkIndent end E.ListIndentEnd + |> P.bind (\_ -> P.loop (chompListEnd syntaxVersion start) ( postEntryComments, [ ( ( [], comments, Nothing ), entry ) ] )) + ) + , P.word1 ']' E.ListOpen + |> P.bind (\_ -> P.addEnd start (Src.List [] comments)) + ] + ) + ) + + +chompListEnd : SyntaxVersion -> A.Position -> Src.C1 (List (Src.C2Eol Src.Expr)) -> P.Parser E.List_ (P.Step (Src.C1 (List (Src.C2Eol Src.Expr))) Src.Expr) +chompListEnd syntaxVersion start ( trailingComments, entries ) = + P.oneOf E.ListEnd + [ P.word1 ',' E.ListEnd + |> P.bind (\_ -> Space.chompAndCheckIndent E.ListSpace E.ListIndentExpr) + |> P.bind + (\postComments -> + P.specialize E.ListExpr (expression syntaxVersion) + |> P.bind + (\( ( preComments, entry ), end ) -> + Space.checkIndent end E.ListIndentEnd + |> P.fmap (\_ -> P.Loop ( preComments, ( ( trailingComments, postComments, Nothing ), entry ) :: entries )) + ) + ) + , P.word1 ']' E.ListEnd + |> P.bind (\_ -> P.addEnd start (Src.List (List.reverse entries) trailingComments)) + |> P.fmap P.Done + ] + + + +-- TUPLES + + +tuple : SyntaxVersion -> A.Position -> P.Parser E.Expr Src.Expr +tuple syntaxVersion ((A.Position row col) as start) = + P.inContext E.Tuple (P.word1 '(' E.Start) <| + (P.getPosition + |> P.bind + (\before -> + Space.chompAndCheckIndent E.TupleSpace E.TupleIndentExpr1 + |> P.bind + (\preEntryComments -> + P.getPosition + |> P.bind + (\after -> + if before /= after then + P.specialize E.TupleExpr (expression syntaxVersion) + |> P.bind + (\( ( postEntryComments, entry ), end ) -> + Space.checkIndent end E.TupleIndentEnd + |> P.bind (\_ -> chompTupleEnd syntaxVersion start ( ( preEntryComments, postEntryComments ), entry ) []) + ) + + else + P.oneOf E.TupleIndentExpr1 + [ Symbol.operator E.TupleIndentExpr1 E.TupleOperatorReserved + |> P.bind + (\op -> + if op == "-" then + P.oneOf E.TupleOperatorClose + [ P.word1 ')' E.TupleOperatorClose + |> P.bind (\_ -> P.addEnd start (Src.Op op)) + , P.specialize E.TupleExpr + (term syntaxVersion + |> P.bind + (\((A.At (A.Region _ end) _) as negatedExpr) -> + Space.chomp E.Space + |> P.bind + (\postTermComments -> + let + exprStart : A.Position + exprStart = + A.Position row (col + 2) + + expr : A.Located Src.Expr_ + expr = + A.at exprStart end (Src.Negate negatedExpr) + in + chompExprEnd syntaxVersion + exprStart + (State + { ops = [] + , expr = expr + , args = [] + , end = end + } + ) + postTermComments + ) + ) + ) + |> P.bind + (\( ( postEntryComments, entry ), end ) -> + Space.checkIndent end E.TupleIndentEnd + |> P.bind (\_ -> chompTupleEnd syntaxVersion start ( ( preEntryComments, postEntryComments ), entry ) []) + ) + ] + + else + P.word1 ')' E.TupleOperatorClose + |> P.bind (\_ -> P.addEnd start (Src.Op op)) + ) + , P.word1 ')' E.TupleIndentExpr1 + |> P.bind (\_ -> P.addEnd start Src.Unit) + , P.specialize E.TupleExpr (expression syntaxVersion) + |> P.bind + (\( ( postEntryComments, entry ), end ) -> + Space.checkIndent end E.TupleIndentEnd + |> P.bind (\_ -> chompTupleEnd syntaxVersion start ( ( preEntryComments, postEntryComments ), entry ) []) + ) + ] + ) + ) + ) + ) + + +chompTupleEnd : SyntaxVersion -> A.Position -> Src.C2 Src.Expr -> List (Src.C2 Src.Expr) -> P.Parser E.Tuple Src.Expr +chompTupleEnd syntaxVersion start firstExpr revExprs = + P.oneOf E.TupleEnd + [ P.word1 ',' E.TupleEnd + |> P.bind + (\_ -> + Space.chompAndCheckIndent E.TupleSpace E.TupleIndentExprN + |> P.bind + (\preEntryComments -> + P.specialize E.TupleExpr (expression syntaxVersion) + |> P.bind + (\( ( postEntryComments, entry ), end ) -> + Space.checkIndent end E.TupleIndentEnd + |> P.bind (\_ -> chompTupleEnd syntaxVersion start firstExpr (( ( preEntryComments, postEntryComments ), entry ) :: revExprs)) + ) + ) + ) + , P.word1 ')' E.TupleEnd + |> P.bind + (\_ -> + case List.reverse revExprs of + [] -> + P.addEnd start (Src.Parens firstExpr) + + secondExpr :: otherExprs -> + P.addEnd start (Src.Tuple firstExpr secondExpr otherExprs) + ) + ] + + + +-- RECORDS + + +record : SyntaxVersion -> A.Position -> P.Parser E.Expr Src.Expr +record syntaxVersion start = + case syntaxVersion of + SV.Elm -> + P.inContext E.Record (P.word1 '{' E.Start) <| + (Space.chompAndCheckIndent E.RecordSpace E.RecordIndentOpen + |> P.bind + (\preStarterNameComments -> + P.oneOf E.RecordOpen + [ P.word1 '}' E.RecordOpen + |> P.bind (\_ -> P.addEnd start (Src.Record ( preStarterNameComments, [] ))) + , P.addLocation (Var.lower E.RecordField) + |> P.bind + (\((A.At starterPosition starterName) as starter) -> + Space.chompAndCheckIndent E.RecordSpace E.RecordIndentEquals + |> P.bind + (\postStarterNameComments -> + P.oneOf E.RecordEquals + [ P.word1 '|' E.RecordEquals + |> P.bind (\_ -> Space.chompAndCheckIndent E.RecordSpace E.RecordIndentField) + |> P.bind + (\postPipeComments -> + chompField syntaxVersion [] postPipeComments + ) + |> P.bind (\( postFirstFieldComments, firstField ) -> chompFields syntaxVersion postFirstFieldComments [ firstField ]) + |> P.bind (\fields -> P.addEnd start (Src.Update ( ( preStarterNameComments, postStarterNameComments ), A.At starterPosition (Src.Var Src.LowVar starterName) ) fields)) + , P.word1 '=' E.RecordEquals + |> P.bind (\_ -> Space.chompAndCheckIndent E.RecordSpace E.RecordIndentExpr) + |> P.bind + (\preValueComments -> + P.specialize E.RecordExpr (expression syntaxVersion) + |> P.bind + (\( ( postValueComments, value ), end ) -> + Space.checkIndent end E.RecordIndentEnd + |> P.bind (\_ -> chompFields syntaxVersion postValueComments [ ( ( [], preStarterNameComments, Nothing ), ( ( postStarterNameComments, starter ), ( preValueComments, value ) ) ) ]) + |> P.bind (\fields -> P.addEnd start (Src.Record fields)) + ) + ) + ] + ) + ) + ] + ) + ) + + SV.Guida -> + P.inContext E.Record (P.word1 '{' E.Start) <| + (Space.chompAndCheckIndent E.RecordSpace E.RecordIndentOpen + |> P.bind + (\preStarterNameComments -> + P.oneOf E.RecordOpen + [ P.word1 '}' E.RecordOpen + |> P.bind (\_ -> P.addEnd start (Src.Record ( preStarterNameComments, [] ))) + , P.getPosition + |> P.bind + (\nameStart -> + foreignAlpha E.RecordField + |> P.bind (\var -> P.addEnd nameStart var) + |> P.bind (accessibleRecord nameStart) + |> P.bind + (\starter -> + Space.chompAndCheckIndent E.RecordSpace E.RecordIndentEquals + |> P.bind + (\postStarterNameComments -> + P.word1 '|' E.RecordEquals + |> P.bind (\_ -> Space.chompAndCheckIndent E.RecordSpace E.RecordIndentField) + |> P.bind (\postPipeComments -> chompField syntaxVersion [] postPipeComments) + |> P.bind (\( postFirstFieldComments, firstField ) -> chompFields syntaxVersion postFirstFieldComments [ firstField ]) + |> P.bind (\fields -> P.addEnd start (Src.Update ( ( preStarterNameComments, postStarterNameComments ), starter ) fields)) + ) + ) + ) + , P.addLocation (Var.lower E.RecordField) + |> P.bind + (\starter -> + Space.chompAndCheckIndent E.RecordSpace E.RecordIndentEquals + |> P.bind + (\postStarterNameComments -> + P.word1 '=' E.RecordEquals + |> P.bind (\_ -> Space.chompAndCheckIndent E.RecordSpace E.RecordIndentExpr) + |> P.bind + (\preValueComments -> + P.specialize E.RecordExpr (expression syntaxVersion) + |> P.bind + (\( ( postValueComments, value ), end ) -> + Space.checkIndent end E.RecordIndentEnd + |> P.bind (\_ -> chompFields syntaxVersion postValueComments [ ( ( [], preStarterNameComments, Nothing ), ( ( postStarterNameComments, starter ), ( preValueComments, value ) ) ) ]) + |> P.bind (\fields -> P.addEnd start (Src.Record fields)) + ) + ) + ) + ) + ] + ) + ) + + +accessibleRecord : A.Position -> Src.Expr -> P.Parser E.Record Src.Expr +accessibleRecord start expr = + P.oneOfWithFallback + [ P.word1 '.' E.RecordOpen + |> P.bind (\_ -> P.getPosition) + |> P.bind + (\pos -> + Var.lower E.RecordOpen + |> P.bind + (\field -> + P.getPosition + |> P.bind + (\end -> + accessibleRecord start <| + A.at start end (Src.Access expr (A.at pos end field)) + ) + ) + ) + ] + expr + + + +-- FOREIGN ALPHA + + +foreignAlpha : (Row -> Col -> x) -> P.Parser x Src.Expr_ +foreignAlpha toError = + P.Parser <| + \(P.State src pos end indent row col) -> + let + ( ( alphaStart, alphaEnd ), ( newCol, varType ) ) = + foreignAlphaHelp src pos end col + in + if alphaStart == alphaEnd then + P.Eerr row newCol toError + + else + case varType of + Src.LowVar -> + let + name : Name + name = + Name.fromPtr src alphaStart alphaEnd + + newState : P.State + newState = + P.State src alphaEnd end indent row newCol + in + if alphaStart == pos then + if Var.isReservedWord name then + P.Eerr row col toError + + else + P.Cok (Src.Var varType name) newState + + else + let + home : Name + home = + Name.fromPtr src pos (alphaStart + -1) + in + P.Cok (Src.VarQual varType home name) newState + + Src.CapVar -> + P.Eerr row col toError + + +foreignAlphaHelp : String -> Int -> Int -> Col -> ( ( Int, Int ), ( Col, Src.VarType ) ) +foreignAlphaHelp src pos end col = + let + ( lowerPos, lowerCol ) = + Var.chompLower src pos end col + in + if pos < lowerPos then + ( ( pos, lowerPos ), ( lowerCol, Src.LowVar ) ) + + else + let + ( upperPos, upperCol ) = + Var.chompUpper src pos end col + in + if pos == upperPos then + ( ( pos, pos ), ( col, Src.CapVar ) ) + + else if Var.isDot src upperPos end then + foreignAlphaHelp src (upperPos + 1) end (upperCol + 1) + + else + ( ( pos, upperPos ), ( upperCol, Src.CapVar ) ) + + +type alias Field = + Src.C2Eol ( Src.C1 (A.Located Name.Name), Src.C1 Src.Expr ) + + +chompFields : SyntaxVersion -> Src.FComments -> List Field -> P.Parser E.Record (Src.C1 (List Field)) +chompFields syntaxVersion trailingComments fields = + P.oneOf E.RecordEnd + [ P.word1 ',' E.RecordEnd + |> P.bind (\_ -> Space.chompAndCheckIndent E.RecordSpace E.RecordIndentField) + |> P.bind (\postCommaComments -> chompField syntaxVersion trailingComments postCommaComments) + |> P.bind (\( postFieldComments, f ) -> chompFields syntaxVersion postFieldComments (f :: fields)) + , P.word1 '}' E.RecordEnd + |> P.fmap (\_ -> ( trailingComments, List.reverse fields )) + ] + + +chompField : SyntaxVersion -> Src.FComments -> Src.FComments -> P.Parser E.Record (Src.C1 Field) +chompField syntaxVersion preCommaComents postCommaComments = + P.addLocation (Var.lower E.RecordField) + |> P.bind + (\key -> + Space.chompAndCheckIndent E.RecordSpace E.RecordIndentEquals + |> P.bind + (\preEqualSignComments -> + P.word1 '=' E.RecordEquals + |> P.bind (\_ -> Space.chompAndCheckIndent E.RecordSpace E.RecordIndentExpr) + |> P.bind + (\postEqualSignComments -> + P.specialize E.RecordExpr (expression syntaxVersion) + |> P.bind + (\( ( postFieldComments, value ), end ) -> + Space.checkIndent end E.RecordIndentEnd + |> P.fmap + (\_ -> + ( postFieldComments + , ( ( preCommaComents, postCommaComments, Nothing ), ( ( preEqualSignComments, key ), ( postEqualSignComments, value ) ) ) + ) + ) + ) + ) + ) + ) + + + +-- EXPRESSIONS + + +expression : SyntaxVersion -> Space.Parser E.Expr (Src.C1 Src.Expr) +expression syntaxVersion = + P.getPosition + |> P.bind + (\start -> + P.oneOf E.Start + [ let_ syntaxVersion start + , if_ syntaxVersion start + , case_ syntaxVersion start + , function syntaxVersion start + , possiblyNegativeTerm syntaxVersion start + |> P.bind + (\expr -> + P.getPosition + |> P.bind + (\end -> + Space.chomp E.Space + |> P.bind + (\comments -> + chompExprEnd syntaxVersion + start + (State + { ops = [] + , expr = expr + , args = [] + , end = end + } + ) + comments + ) + ) + ) + ] + ) + + +type State + = State + { ops : List ( Src.Expr, Src.C2 (A.Located Name.Name) ) + , expr : Src.Expr + , args : List (Src.C1 Src.Expr) + , end : A.Position + } + + +chompExprEnd : SyntaxVersion -> A.Position -> State -> Src.FComments -> Space.Parser E.Expr (Src.C1 Src.Expr) +chompExprEnd syntaxVersion start (State { ops, expr, args, end }) comments = + P.oneOfWithFallback + [ -- argument + Space.checkIndent end E.Start + |> P.bind (\_ -> term syntaxVersion) + |> P.bind + (\arg -> + P.getPosition + |> P.bind + (\newEnd -> + Space.chomp E.Space + |> P.bind + (\trailingComments -> + chompExprEnd syntaxVersion + start + (State + { ops = ops + , expr = expr + , args = ( comments, arg ) :: args + , end = newEnd + } + ) + trailingComments + ) + ) + ) + , -- operator + Space.checkIndent end E.Start + |> P.bind (\_ -> P.addLocation (Symbol.operator E.Start E.OperatorReserved)) + |> P.bind + (\((A.At (A.Region opStart opEnd) opName) as op) -> + Space.chompAndCheckIndent E.Space (E.IndentOperatorRight opName) + |> P.bind + (\postOpComments -> + P.getPosition + |> P.bind + (\newStart -> + if "-" == opName && end /= opStart && opEnd == newStart then + -- negative terms + term syntaxVersion + |> P.bind + (\negatedExpr -> + P.getPosition + |> P.bind + (\newEnd -> + Space.chomp E.Space + |> P.bind + (\postNegatedExprComments -> + let + arg : Src.C1 (A.Located Src.Expr_) + arg = + ( postNegatedExprComments, A.at opStart newEnd (Src.Negate negatedExpr) ) + in + chompExprEnd syntaxVersion + start + (State + { ops = ops + , expr = expr + , args = arg :: args + , end = newEnd + } + ) + [] + ) + ) + ) + + else + let + err : P.Row -> P.Col -> E.Expr + err = + E.OperatorRight opName + in + P.oneOf err + [ -- term + possiblyNegativeTerm syntaxVersion newStart + |> P.bind + (\newExpr -> + P.getPosition + |> P.bind + (\newEnd -> + Space.chomp E.Space + |> P.bind + (\trailingComments -> + let + newOps : List ( Src.Expr, Src.C2 (A.Located Name.Name) ) + newOps = + ( toCall expr args, ( ( comments, postOpComments ), op ) ) :: ops + in + chompExprEnd syntaxVersion + start + (State + { ops = newOps + , expr = newExpr + , args = [] + , end = newEnd + } + ) + trailingComments + ) + ) + ) + , -- final term + P.oneOf err + [ let_ syntaxVersion newStart + , case_ syntaxVersion newStart + , if_ syntaxVersion newStart + , function syntaxVersion newStart + ] + |> P.fmap + (\( ( trailingComments, newLast ), newEnd ) -> + let + newOps : List ( Src.Expr, Src.C2 (A.Located Name.Name) ) + newOps = + ( toCall expr args, ( ( comments, [] ), op ) ) :: ops + + finalExpr : Src.Expr_ + finalExpr = + Src.Binops (List.reverse newOps) newLast + in + ( ( trailingComments, A.at start newEnd finalExpr ), newEnd ) + ) + ] + ) + ) + ) + ] + -- done + (case ops of + [] -> + ( ( comments, toCall expr args ) + , end + ) + + _ -> + ( ( comments, A.at start end (Src.Binops (List.reverse ops) (toCall expr args)) ) + , end + ) + ) + + +possiblyNegativeTerm : SyntaxVersion -> A.Position -> P.Parser E.Expr Src.Expr +possiblyNegativeTerm syntaxVersion start = + P.oneOf E.Start + [ P.word1 '-' E.Start + |> P.bind + (\_ -> + term syntaxVersion + |> P.bind + (\expr -> + P.addEnd start (Src.Negate expr) + ) + ) + , term syntaxVersion + ] + + +toCall : Src.Expr -> List (Src.C1 Src.Expr) -> Src.Expr +toCall func revArgs = + case revArgs of + [] -> + func + + ( _, lastArg ) :: _ -> + A.merge func lastArg (Src.Call func (List.reverse revArgs)) + + + +-- IF EXPRESSION + + +if_ : SyntaxVersion -> A.Position -> Space.Parser E.Expr (Src.C1 Src.Expr) +if_ syntaxVersion start = + P.inContext E.If (Keyword.if_ E.Start) <| + chompIfEnd syntaxVersion start [] [] + + +chompIfEnd : SyntaxVersion -> A.Position -> Src.FComments -> List (Src.C1 ( Src.C2 Src.Expr, Src.C2 Src.Expr )) -> Space.Parser E.If (Src.C1 Src.Expr) +chompIfEnd syntaxVersion start comments branches = + Space.chompAndCheckIndent E.IfSpace E.IfIndentCondition + |> P.bind + (\preConditionComments -> + P.specialize E.IfCondition (expression syntaxVersion) + |> P.bind + (\( ( postConditionComments, condition ), condEnd ) -> + Space.checkIndent condEnd E.IfIndentThen + |> P.bind (\_ -> Keyword.then_ E.IfThen) + |> P.bind (\_ -> Space.chompAndCheckIndent E.IfSpace E.IfIndentThenBranch) + |> P.bind + (\preThenBranchComments -> + P.specialize E.IfThenBranch (expression syntaxVersion) + |> P.bind + (\( ( postThenBranchComments, thenBranch ), thenEnd ) -> + Space.checkIndent thenEnd E.IfIndentElse + |> P.bind (\_ -> Keyword.else_ E.IfElse) + |> P.bind (\_ -> Space.chompAndCheckIndent E.IfSpace E.IfIndentElseBranch) + |> P.bind + (\trailingComments -> + let + newBranch : Src.C1 ( Src.C2 Src.Expr, Src.C2 Src.Expr ) + newBranch = + ( comments, ( ( ( preConditionComments, postConditionComments ), condition ), ( ( preThenBranchComments, postThenBranchComments ), thenBranch ) ) ) + + newBranches : List (Src.C1 ( Src.C2 Src.Expr, Src.C2 Src.Expr )) + newBranches = + newBranch :: branches + in + P.oneOf E.IfElseBranchStart + [ Keyword.if_ E.IfElseBranchStart + |> P.bind (\_ -> chompIfEnd syntaxVersion start trailingComments newBranches) + , P.specialize E.IfElseBranch (expression syntaxVersion) + |> P.fmap + (\( ( postElseBranch, elseBranch ), elseEnd ) -> + let + reversedBranches : List (Src.C1 ( Src.C2 Src.Expr, Src.C2 Src.Expr )) + reversedBranches = + List.reverse newBranches + + ifExpr : Src.Expr_ + ifExpr = + Src.If (Maybe.withDefault newBranch (List.head reversedBranches)) (Maybe.withDefault [] (List.tail reversedBranches)) ( trailingComments, elseBranch ) + in + ( ( postElseBranch, A.at start elseEnd ifExpr ), elseEnd ) + ) + ] + ) + ) + ) + ) + ) + + + +-- LAMBDA EXPRESSION + + +function : SyntaxVersion -> A.Position -> Space.Parser E.Expr (Src.C1 Src.Expr) +function syntaxVersion start = + P.inContext E.Func (P.word1 '\\' E.Start) <| + (Space.chompAndCheckIndent E.FuncSpace E.FuncIndentArg + |> P.bind + (\preArgComments -> + P.specialize E.FuncArg (Pattern.term syntaxVersion) + |> P.bind + (\arg -> + Space.chompAndCheckIndent E.FuncSpace E.FuncIndentArrow + |> P.bind (\trailingComments -> chompArgs syntaxVersion trailingComments [ ( preArgComments, arg ) ]) + |> P.bind + (\( trailingComments, revArgs ) -> + Space.chompAndCheckIndent E.FuncSpace E.FuncIndentBody + |> P.bind + (\preComments -> + P.specialize E.FuncBody (expression syntaxVersion) + |> P.fmap (Tuple.mapFirst (\( afterBodyComments, body ) -> ( afterBodyComments, ( preComments, body ) ))) + ) + |> P.fmap + (\( ( afterBodyComments, body ), end ) -> + let + funcExpr : Src.Expr_ + funcExpr = + Src.Lambda ( trailingComments, List.reverse revArgs ) body + in + ( ( afterBodyComments, A.at start end funcExpr ), end ) + ) + ) + ) + ) + ) + + +chompArgs : SyntaxVersion -> Src.FComments -> List (Src.C1 Src.Pattern) -> P.Parser E.Func (Src.C1 (List (Src.C1 Src.Pattern))) +chompArgs syntaxVersion trailingComments revArgs = + P.oneOf E.FuncArrow + [ P.specialize E.FuncArg (Pattern.term syntaxVersion) + |> P.bind + (\arg -> + Space.chompAndCheckIndent E.FuncSpace E.FuncIndentArrow + |> P.bind (\postArgComments -> chompArgs syntaxVersion postArgComments (( trailingComments, arg ) :: revArgs)) + ) + , P.word2 '-' '>' E.FuncArrow + |> P.fmap (\_ -> ( trailingComments, revArgs )) + ] + + + +-- CASE EXPRESSIONS + + +case_ : SyntaxVersion -> A.Position -> Space.Parser E.Expr (Src.C1 Src.Expr) +case_ syntaxVersion start = + P.inContext E.Case (Keyword.case_ E.Start) <| + (Space.chompAndCheckIndent E.CaseSpace E.CaseIndentExpr + |> P.bind + (\preExprComments -> + P.specialize E.CaseExpr (expression syntaxVersion) + |> P.bind + (\( ( postExprComments, expr ), exprEnd ) -> + Space.checkIndent exprEnd E.CaseIndentOf + |> P.bind (\_ -> Keyword.of_ E.CaseOf) + |> P.bind (\_ -> Space.chompAndCheckIndent E.CaseSpace E.CaseIndentPattern) + |> P.bind + (\comments -> + P.withIndent + (chompBranch syntaxVersion comments + |> P.bind + (\( ( trailingComments, firstBranch ), firstEnd ) -> + chompCaseEnd syntaxVersion trailingComments [ firstBranch ] firstEnd + |> P.fmap + (\( ( branchesTrailingComments, branches ), end ) -> + ( ( branchesTrailingComments, A.at start end (Src.Case ( ( preExprComments, postExprComments ), expr ) branches) ) + , end + ) + ) + ) + ) + ) + ) + ) + ) + + +chompBranch : SyntaxVersion -> Src.FComments -> Space.Parser E.Case (Src.C1 ( Src.C2 Src.Pattern, Src.C1 Src.Expr )) +chompBranch syntaxVersion prePatternComments = + P.specialize E.CasePattern (Pattern.expression syntaxVersion) + |> P.bind + (\( ( postPatternComments, pattern ), patternEnd ) -> + Space.checkIndent patternEnd E.CaseIndentArrow + |> P.bind (\_ -> P.word2 '-' '>' E.CaseArrow) + |> P.bind (\_ -> Space.chompAndCheckIndent E.CaseSpace E.CaseIndentBranch) + |> P.bind + (\preBranchExprComments -> + P.specialize E.CaseBranch (expression syntaxVersion) + |> P.fmap + (\( ( trailingComments, branchExpr ), end ) -> + ( ( trailingComments + , ( ( ( prePatternComments, postPatternComments ), pattern ) + , ( preBranchExprComments, branchExpr ) + ) + ) + , end + ) + ) + ) + ) + + +chompCaseEnd : SyntaxVersion -> Src.FComments -> List ( Src.C2 Src.Pattern, Src.C1 Src.Expr ) -> A.Position -> Space.Parser E.Case (Src.C1 (List ( Src.C2 Src.Pattern, Src.C1 Src.Expr ))) +chompCaseEnd syntaxVersion prePatternComments branches end = + P.oneOfWithFallback + [ Space.checkAligned E.CasePatternAlignment + |> P.bind (\_ -> chompBranch syntaxVersion prePatternComments) + |> P.bind (\( ( comments, branch ), newEnd ) -> chompCaseEnd syntaxVersion comments (branch :: branches) newEnd) + ] + ( ( prePatternComments, List.reverse branches ), end ) + + + +-- LET EXPRESSION + + +let_ : SyntaxVersion -> A.Position -> Space.Parser E.Expr (Src.C1 Src.Expr) +let_ syntaxVersion start = + P.inContext E.Let (Keyword.let_ E.Start) <| + ((P.withBacksetIndent 3 <| + (Space.chompAndCheckIndent E.LetSpace E.LetIndentDef + |> P.bind + (\preDefComments -> + P.withIndent <| + (chompLetDef syntaxVersion + |> P.bind (\( ( postDefComments, def ), end ) -> chompLetDefs syntaxVersion [ ( ( preDefComments, postDefComments ), def ) ] end) + ) + ) + ) + ) + |> P.bind + (\( defs, defsEnd ) -> + Space.checkIndent defsEnd E.LetIndentIn + |> P.bind (\_ -> Keyword.in_ E.LetIn) + |> P.bind (\_ -> Space.chompAndCheckIndent E.LetSpace E.LetIndentBody) + |> P.bind + (\bodyComments -> + P.specialize E.LetBody (expression syntaxVersion) + |> P.fmap + (\( ( trailingComments, body ), end ) -> + ( ( trailingComments, A.at start end (Src.Let defs bodyComments body) ), end ) + ) + ) + ) + ) + + +chompLetDefs : SyntaxVersion -> List (Src.C2 (A.Located Src.Def)) -> A.Position -> Space.Parser E.Let (List (Src.C2 (A.Located Src.Def))) +chompLetDefs syntaxVersion revDefs end = + P.oneOfWithFallback + [ Space.checkAligned E.LetDefAlignment + |> P.bind (\_ -> chompLetDef syntaxVersion) + |> P.bind (\( ( postDefComments, def ), newEnd ) -> chompLetDefs syntaxVersion (( ( [], postDefComments ), def ) :: revDefs) newEnd) + ] + ( List.reverse revDefs, end ) + + + +-- LET DEFINITIONS + + +chompLetDef : SyntaxVersion -> Space.Parser E.Let (Src.C1 (A.Located Src.Def)) +chompLetDef syntaxVersion = + P.oneOf E.LetDefName + [ definition syntaxVersion + , destructure syntaxVersion + ] + + + +-- DEFINITION + + +definition : SyntaxVersion -> Space.Parser E.Let (Src.C1 (A.Located Src.Def)) +definition syntaxVersion = + P.addLocation (Var.lower E.LetDefName) + |> P.bind + (\((A.At (A.Region start _) name) as aname) -> + P.specialize (E.LetDef name) <| + (Space.chompAndCheckIndent E.DefSpace E.DefIndentEquals + |> P.bind + (\postNameComments -> + P.oneOf E.DefEquals + [ P.word1 ':' E.DefEquals + |> P.bind (\_ -> Space.chompAndCheckIndent E.DefSpace E.DefIndentType) + |> P.bind + (\preTypeComments -> + P.specialize E.DefType (Type.expression preTypeComments) + ) + |> P.bind + (\( ( ( preTipeComments, postTipeComments, _ ), tipe ), _ ) -> + Space.checkAligned E.DefAlignment + |> P.bind (\_ -> chompMatchingName name) + |> P.bind + (\defName -> + Space.chompAndCheckIndent E.DefSpace E.DefIndentEquals + |> P.bind + (\trailingComments -> + chompDefArgsAndBody syntaxVersion start defName (Just ( postTipeComments, ( ( postNameComments, preTipeComments ), tipe ) )) trailingComments [] + ) + ) + ) + , chompDefArgsAndBody syntaxVersion start aname Nothing postNameComments [] + ] + ) + ) + ) + + +chompDefArgsAndBody : SyntaxVersion -> A.Position -> A.Located Name.Name -> Maybe (Src.C1 (Src.C2 Src.Type)) -> Src.FComments -> List (Src.C1 Src.Pattern) -> Space.Parser E.Def (Src.C1 (A.Located Src.Def)) +chompDefArgsAndBody syntaxVersion start name tipe trailingComments revArgs = + P.oneOf E.DefEquals + [ P.specialize E.DefArg (Pattern.term syntaxVersion) + |> P.bind + (\arg -> + Space.chompAndCheckIndent E.DefSpace E.DefIndentEquals + |> P.bind (\comments -> chompDefArgsAndBody syntaxVersion start name tipe comments (( trailingComments, arg ) :: revArgs)) + ) + , P.word1 '=' E.DefEquals + |> P.bind (\_ -> Space.chompAndCheckIndent E.DefSpace E.DefIndentBody) + |> P.bind + (\preExpressionComments -> + P.specialize E.DefBody (expression syntaxVersion) + |> P.fmap + (\( ( comments, body ), end ) -> + ( ( comments, A.at start end (Src.Define name (List.reverse revArgs) ( trailingComments ++ preExpressionComments, body ) tipe) ) + , end + ) + ) + ) + ] + + +chompMatchingName : Name.Name -> P.Parser E.Def (A.Located Name.Name) +chompMatchingName expectedName = + let + (P.Parser parserL) = + Var.lower E.DefNameRepeat + in + P.Parser <| + \((P.State _ _ _ _ sr sc) as state) -> + case parserL state of + P.Cok name ((P.State _ _ _ _ er ec) as newState) -> + if expectedName == name then + P.Cok (A.At (A.Region (A.Position sr sc) (A.Position er ec)) name) newState + + else + P.Cerr sr sc (E.DefNameMatch name) + + P.Eok name ((P.State _ _ _ _ er ec) as newState) -> + if expectedName == name then + P.Eok (A.At (A.Region (A.Position sr sc) (A.Position er ec)) name) newState + + else + P.Eerr sr sc (E.DefNameMatch name) + + P.Cerr r c t -> + P.Cerr r c t + + P.Eerr r c t -> + P.Eerr r c t + + + +-- DESTRUCTURE + + +destructure : SyntaxVersion -> Space.Parser E.Let (Src.C1 (A.Located Src.Def)) +destructure syntaxVersion = + P.specialize E.LetDestruct <| + (P.getPosition + |> P.bind + (\start -> + P.specialize E.DestructPattern (Pattern.term syntaxVersion) + |> P.bind + (\pattern -> + Space.chompAndCheckIndent E.DestructSpace E.DestructIndentEquals + |> P.bind + (\preEqualSignComments -> + P.word1 '=' E.DestructEquals + |> P.bind (\_ -> Space.chompAndCheckIndent E.DestructSpace E.DestructIndentBody) + |> P.bind + (\preExpressionComments -> + P.specialize E.DestructBody (expression syntaxVersion) + |> P.fmap + (\( ( comments, expr ), end ) -> + ( ( comments, A.at start end (Src.Destruct pattern ( preEqualSignComments ++ preExpressionComments, expr )) ) + , end + ) + ) + ) + ) + ) + ) + ) diff --git a/src/Compiler/Parse/Keyword.elm b/src/Compiler/Parse/Keyword.elm new file mode 100644 index 0000000000..db71d5972f --- /dev/null +++ b/src/Compiler/Parse/Keyword.elm @@ -0,0 +1,405 @@ +module Compiler.Parse.Keyword exposing + ( alias_ + , as_ + , case_ + , command_ + , effect_ + , else_ + , exposing_ + , if_ + , import_ + , in_ + , infix_ + , k4 + , k5 + , left_ + , let_ + , module_ + , non_ + , of_ + , port_ + , right_ + , subscription_ + , then_ + , type_ + , where_ + ) + +import Compiler.Parse.Primitives as P exposing (Col, Parser, Row) +import Compiler.Parse.Variable as Var + + + +-- DECLARATIONS + + +type_ : (Row -> Col -> x) -> Parser x () +type_ tx = + k4 't' 'y' 'p' 'e' tx + + +alias_ : (Row -> Col -> x) -> Parser x () +alias_ tx = + k5 'a' 'l' 'i' 'a' 's' tx + + +port_ : (Row -> Col -> x) -> Parser x () +port_ tx = + k4 'p' 'o' 'r' 't' tx + + + +-- IF EXPRESSIONS + + +if_ : (Row -> Col -> x) -> Parser x () +if_ tx = + k2 'i' 'f' tx + + +then_ : (Row -> Col -> x) -> Parser x () +then_ tx = + k4 't' 'h' 'e' 'n' tx + + +else_ : (Row -> Col -> x) -> Parser x () +else_ tx = + k4 'e' 'l' 's' 'e' tx + + + +-- CASE EXPRESSIONS + + +case_ : (Row -> Col -> x) -> Parser x () +case_ tx = + k4 'c' 'a' 's' 'e' tx + + +of_ : (Row -> Col -> x) -> Parser x () +of_ tx = + k2 'o' 'f' tx + + + +-- LET EXPRESSIONS + + +let_ : (Row -> Col -> x) -> Parser x () +let_ tx = + k3 'l' 'e' 't' tx + + +in_ : (Row -> Col -> x) -> Parser x () +in_ tx = + k2 'i' 'n' tx + + + +-- INFIXES + + +infix_ : (Row -> Col -> x) -> Parser x () +infix_ tx = + k5 'i' 'n' 'f' 'i' 'x' tx + + +left_ : (Row -> Col -> x) -> Parser x () +left_ tx = + k4 'l' 'e' 'f' 't' tx + + +right_ : (Row -> Col -> x) -> Parser x () +right_ tx = + k5 'r' 'i' 'g' 'h' 't' tx + + +non_ : (Row -> Col -> x) -> Parser x () +non_ tx = + k3 'n' 'o' 'n' tx + + + +-- IMPORTS + + +module_ : (Row -> Col -> x) -> Parser x () +module_ tx = + k6 'm' 'o' 'd' 'u' 'l' 'e' tx + + +import_ : (Row -> Col -> x) -> Parser x () +import_ tx = + k6 'i' 'm' 'p' 'o' 'r' 't' tx + + +exposing_ : (Row -> Col -> x) -> Parser x () +exposing_ tx = + k8 'e' 'x' 'p' 'o' 's' 'i' 'n' 'g' tx + + +as_ : (Row -> Col -> x) -> Parser x () +as_ tx = + k2 'a' 's' tx + + + +-- EFFECTS + + +effect_ : (Row -> Col -> x) -> Parser x () +effect_ tx = + k6 'e' 'f' 'f' 'e' 'c' 't' tx + + +where_ : (Row -> Col -> x) -> Parser x () +where_ tx = + k5 'w' 'h' 'e' 'r' 'e' tx + + +command_ : (Row -> Col -> x) -> Parser x () +command_ tx = + k7 'c' 'o' 'm' 'm' 'a' 'n' 'd' tx + + +subscription_ : (Row -> Col -> x) -> Parser x () +subscription_ toError = + P.Parser <| + \(P.State src pos end indent row col) -> + let + pos12 : Int + pos12 = + pos + 12 + in + if + (pos12 <= end) + && (P.unsafeIndex src pos == 's') + && (P.unsafeIndex src (pos + 1) == 'u') + && (P.unsafeIndex src (pos + 2) == 'b') + && (P.unsafeIndex src (pos + 3) == 's') + && (P.unsafeIndex src (pos + 4) == 'c') + && (P.unsafeIndex src (pos + 5) == 'r') + && (P.unsafeIndex src (pos + 6) == 'i') + && (P.unsafeIndex src (pos + 7) == 'p') + && (P.unsafeIndex src (pos + 8) == 't') + && (P.unsafeIndex src (pos + 9) == 'i') + && (P.unsafeIndex src (pos + 10) == 'o') + && (P.unsafeIndex src (pos + 11) == 'n') + && (Var.getInnerWidth src pos12 end == 0) + then + let + s : P.State + s = + P.State src pos12 end indent row (col + 12) + in + P.Cok () s + + else + P.Eerr row col toError + + + +-- KEYWORDS + + +k2 : Char -> Char -> (Row -> Col -> x) -> Parser x () +k2 w1 w2 toError = + P.Parser <| + \(P.State src pos end indent row col) -> + let + pos2 : Int + pos2 = + pos + 2 + in + if + (pos2 <= end) + && (P.unsafeIndex src pos == w1) + && (P.unsafeIndex src (pos + 1) == w2) + && (Var.getInnerWidth src pos2 end == 0) + then + let + s : P.State + s = + P.State src pos2 end indent row (col + 2) + in + P.Cok () s + + else + P.Eerr row col toError + + +k3 : Char -> Char -> Char -> (Row -> Col -> x) -> Parser x () +k3 w1 w2 w3 toError = + P.Parser <| + \(P.State src pos end indent row col) -> + let + pos3 : Int + pos3 = + pos + 3 + in + if + (pos3 <= end) + && (P.unsafeIndex src pos == w1) + && (P.unsafeIndex src (pos + 1) == w2) + && (P.unsafeIndex src (pos + 2) == w3) + && (Var.getInnerWidth src pos3 end == 0) + then + let + s : P.State + s = + P.State src pos3 end indent row (col + 3) + in + P.Cok () s + + else + P.Eerr row col toError + + +k4 : Char -> Char -> Char -> Char -> (Row -> Col -> x) -> Parser x () +k4 w1 w2 w3 w4 toError = + P.Parser <| + \(P.State src pos end indent row col) -> + let + pos4 : Int + pos4 = + pos + 4 + in + if + (pos4 <= end) + && (P.unsafeIndex src pos == w1) + && (P.unsafeIndex src (pos + 1) == w2) + && (P.unsafeIndex src (pos + 2) == w3) + && (P.unsafeIndex src (pos + 3) == w4) + && (Var.getInnerWidth src pos4 end == 0) + then + let + s : P.State + s = + P.State src pos4 end indent row (col + 4) + in + P.Cok () s + + else + P.Eerr row col toError + + +k5 : Char -> Char -> Char -> Char -> Char -> (Row -> Col -> x) -> Parser x () +k5 w1 w2 w3 w4 w5 toError = + P.Parser <| + \(P.State src pos end indent row col) -> + let + pos5 : Int + pos5 = + pos + 5 + in + if + (pos5 <= end) + && (P.unsafeIndex src pos == w1) + && (P.unsafeIndex src (pos + 1) == w2) + && (P.unsafeIndex src (pos + 2) == w3) + && (P.unsafeIndex src (pos + 3) == w4) + && (P.unsafeIndex src (pos + 4) == w5) + && (Var.getInnerWidth src pos5 end == 0) + then + let + s : P.State + s = + P.State src pos5 end indent row (col + 5) + in + P.Cok () s + + else + P.Eerr row col toError + + +k6 : Char -> Char -> Char -> Char -> Char -> Char -> (Row -> Col -> x) -> Parser x () +k6 w1 w2 w3 w4 w5 w6 toError = + P.Parser <| + \(P.State src pos end indent row col) -> + let + pos6 : Int + pos6 = + pos + 6 + in + if + (pos6 <= end) + && (P.unsafeIndex src pos == w1) + && (P.unsafeIndex src (pos + 1) == w2) + && (P.unsafeIndex src (pos + 2) == w3) + && (P.unsafeIndex src (pos + 3) == w4) + && (P.unsafeIndex src (pos + 4) == w5) + && (P.unsafeIndex src (pos + 5) == w6) + && (Var.getInnerWidth src pos6 end == 0) + then + let + s : P.State + s = + P.State src pos6 end indent row (col + 6) + in + P.Cok () s + + else + P.Eerr row col toError + + +k7 : Char -> Char -> Char -> Char -> Char -> Char -> Char -> (Row -> Col -> x) -> Parser x () +k7 w1 w2 w3 w4 w5 w6 w7 toError = + P.Parser <| + \(P.State src pos end indent row col) -> + let + pos7 : Int + pos7 = + pos + 7 + in + if + (pos7 <= end) + && (P.unsafeIndex src pos == w1) + && (P.unsafeIndex src (pos + 1) == w2) + && (P.unsafeIndex src (pos + 2) == w3) + && (P.unsafeIndex src (pos + 3) == w4) + && (P.unsafeIndex src (pos + 4) == w5) + && (P.unsafeIndex src (pos + 5) == w6) + && (P.unsafeIndex src (pos + 6) == w7) + && (Var.getInnerWidth src pos7 end == 0) + then + let + s : P.State + s = + P.State src pos7 end indent row (col + 7) + in + P.Cok () s + + else + P.Eerr row col toError + + +k8 : Char -> Char -> Char -> Char -> Char -> Char -> Char -> Char -> (Row -> Col -> x) -> Parser x () +k8 w1 w2 w3 w4 w5 w6 w7 w8 toError = + P.Parser <| + \(P.State src pos end indent row col) -> + let + pos8 : Int + pos8 = + pos + 8 + in + if + (pos8 <= end) + && (P.unsafeIndex src pos == w1) + && (P.unsafeIndex src (pos + 1) == w2) + && (P.unsafeIndex src (pos + 2) == w3) + && (P.unsafeIndex src (pos + 3) == w4) + && (P.unsafeIndex src (pos + 4) == w5) + && (P.unsafeIndex src (pos + 5) == w6) + && (P.unsafeIndex src (pos + 6) == w7) + && (P.unsafeIndex src (pos + 7) == w8) + && (Var.getInnerWidth src pos8 end == 0) + then + let + s : P.State + s = + P.State src pos8 end indent row (col + 8) + in + P.Cok () s + + else + P.Eerr row col toError diff --git a/src/Compiler/Parse/Module.elm b/src/Compiler/Parse/Module.elm new file mode 100644 index 0000000000..bf788c4f79 --- /dev/null +++ b/src/Compiler/Parse/Module.elm @@ -0,0 +1,870 @@ +module Compiler.Parse.Module exposing + ( Effects(..) + , Header + , Module + , ProjectType(..) + , chompImport + , chompImports + , chompModule + , defaultHeader + , fromByteString + , isKernel + ) + +import Compiler.AST.Source as Src +import Compiler.Data.Name as Name +import Compiler.Elm.Compiler.Imports as Imports +import Compiler.Elm.Package as Pkg +import Compiler.Parse.Declaration as Decl +import Compiler.Parse.Keyword as Keyword +import Compiler.Parse.Primitives as P exposing (Col, Row) +import Compiler.Parse.Space as Space +import Compiler.Parse.Symbol as Symbol +import Compiler.Parse.SyntaxVersion exposing (SyntaxVersion) +import Compiler.Parse.Variable as Var +import Compiler.Reporting.Annotation as A +import Compiler.Reporting.Error.Syntax as E + + + +-- FROM BYTE STRING + + +fromByteString : SyntaxVersion -> ProjectType -> String -> Result E.Error Src.Module +fromByteString syntaxVersion projectType source = + case P.fromByteString (chompModule syntaxVersion projectType) E.ModuleBadEnd source of + Ok modul -> + checkModule syntaxVersion projectType modul + + Err err -> + Err (E.ParseError err) + + + +-- PROJECT TYPE + + +type ProjectType + = Package Pkg.Name + | Application + + +isCore : ProjectType -> Bool +isCore projectType = + case projectType of + Package pkg -> + pkg == Pkg.core + + Application -> + False + + +isKernel : ProjectType -> Bool +isKernel projectType = + case projectType of + Package pkg -> + Pkg.isKernel pkg + + Application -> + False + + + +-- MODULE + + +type alias Module = + { initialComments : Src.FComments + , header : Maybe Header + , imports : Src.C1 (List (Src.C1 Src.Import)) + , infixes : List (Src.C1 (A.Located Src.Infix)) + , decls : List (Src.C2 Decl.Decl) + } + + +chompModule : SyntaxVersion -> ProjectType -> P.Parser E.Module Module +chompModule syntaxVersion projectType = + chompHeader + |> P.bind + (\( ( initialComments, headerComments ), header ) -> + chompImports + (if isCore projectType then + [] + + else + Imports.defaults + ) + |> P.bind + (\imports -> + (if isKernel projectType then + chompInfixes [] + + else + P.pure [] + ) + |> P.bind + (\infixes -> + P.specialize E.Declarations (chompDecls syntaxVersion) + |> P.fmap + (\decls -> + Module + initialComments + header + ( headerComments, imports ) + infixes + decls + ) + ) + ) + ) + + + +-- CHECK MODULE + + +checkModule : SyntaxVersion -> ProjectType -> Module -> Result E.Error Src.Module +checkModule syntaxVersion projectType module_ = + let + ( ( values, unions ), ( aliases, ports ) ) = + categorizeDecls [] [] [] [] (List.map Src.c2Value module_.decls) + + ( _, imports ) = + module_.imports + in + case module_.header of + Just ({ effects, docs } as header) -> + let + ( _, name ) = + header.name + + ( _, exports ) = + header.exports + in + checkEffects projectType ports effects + |> Result.map + (Src.Module syntaxVersion + (Just name) + exports + (toDocs docs (List.map Src.c2Value module_.decls)) + (List.map Src.c1Value imports) + values + unions + aliases + (List.map Src.c1Value module_.infixes) + ) + + Nothing -> + Ok + (Src.Module syntaxVersion + Nothing + (A.At A.one (Src.Open [] [])) + (toDocs (Err A.one) (List.map Src.c2Value module_.decls)) + (List.map Src.c1Value imports) + values + unions + aliases + (List.map Src.c1Value module_.infixes) + (case ports of + [] -> + Src.NoEffects + + _ -> + Src.Ports ports + ) + ) + + +checkEffects : ProjectType -> List Src.Port -> Effects -> Result E.Error Src.Effects +checkEffects projectType ports effects = + case effects of + NoEffects region -> + case ports of + [] -> + Ok Src.NoEffects + + (Src.Port _ ( _, name ) _) :: _ -> + case projectType of + Package _ -> + Err (E.NoPortsInPackage name) + + Application -> + Err (E.UnexpectedPort region) + + Ports region _ -> + case projectType of + Package _ -> + Err (E.NoPortModulesInPackage region) + + Application -> + case ports of + [] -> + Err (E.NoPorts region) + + _ :: _ -> + Ok (Src.Ports ports) + + Manager region _ ( _, manager ) -> + if isKernel projectType then + case ports of + [] -> + Ok (Src.Manager region manager) + + _ :: _ -> + Err (E.UnexpectedPort region) + + else + Err (E.NoEffectsOutsideKernel region) + + +categorizeDecls : List (A.Located Src.Value) -> List (A.Located Src.Union) -> List (A.Located Src.Alias) -> List Src.Port -> List Decl.Decl -> ( ( List (A.Located Src.Value), List (A.Located Src.Union) ), ( List (A.Located Src.Alias), List Src.Port ) ) +categorizeDecls values unions aliases ports decls = + case decls of + [] -> + ( ( values, unions ), ( aliases, ports ) ) + + decl :: otherDecls -> + case decl of + Decl.Value _ value -> + categorizeDecls (value :: values) unions aliases ports otherDecls + + Decl.Union _ union -> + categorizeDecls values (union :: unions) aliases ports otherDecls + + Decl.Alias _ alias_ -> + categorizeDecls values unions (alias_ :: aliases) ports otherDecls + + Decl.Port _ port_ -> + categorizeDecls values unions aliases (port_ :: ports) otherDecls + + + +-- TO DOCS + + +toDocs : Result A.Region Src.Comment -> List Decl.Decl -> Src.Docs +toDocs comment decls = + case comment of + Ok overview -> + Src.YesDocs overview (getComments decls []) + + Err region -> + Src.NoDocs region (getComments decls []) + + +getComments : List Decl.Decl -> List ( Name.Name, Src.Comment ) -> List ( Name.Name, Src.Comment ) +getComments decls comments = + case decls of + [] -> + comments + + decl :: otherDecls -> + case decl of + Decl.Value c (A.At _ (Src.Value _ ( _, n ) _ _ _)) -> + getComments otherDecls (addComment c n comments) + + Decl.Union c (A.At _ (Src.Union ( _, n ) _ _)) -> + getComments otherDecls (addComment c n comments) + + Decl.Alias c (A.At _ (Src.Alias _ ( _, n ) _ _)) -> + getComments otherDecls (addComment c n comments) + + Decl.Port c (Src.Port _ ( _, n ) _) -> + getComments otherDecls (addComment c n comments) + + +addComment : Maybe Src.Comment -> A.Located Name.Name -> List ( Name.Name, Src.Comment ) -> List ( Name.Name, Src.Comment ) +addComment maybeComment (A.At _ name) comments = + case maybeComment of + Just comment -> + ( name, comment ) :: comments + + Nothing -> + comments + + + +-- FRESH LINES + + +freshLine : (Row -> Col -> E.Module) -> P.Parser E.Module Src.FComments +freshLine toFreshLineError = + Space.chomp E.ModuleSpace + |> P.bind + (\comments -> + Space.checkFreshLine toFreshLineError + |> P.fmap (\_ -> comments) + ) + + + +-- CHOMP DECLARATIONS + + +chompDecls : SyntaxVersion -> P.Parser E.Decl (List (Src.C2 Decl.Decl)) +chompDecls syntaxVersion = + Decl.declaration syntaxVersion + |> P.bind (\( decl, _ ) -> P.loop (chompDeclsHelp syntaxVersion) [ decl ]) + + +chompDeclsHelp : SyntaxVersion -> List (Src.C2 Decl.Decl) -> P.Parser E.Decl (P.Step (List (Src.C2 Decl.Decl)) (List (Src.C2 Decl.Decl))) +chompDeclsHelp syntaxVersion decls = + P.oneOfWithFallback + [ Space.checkFreshLine E.DeclStart + |> P.bind + (\_ -> + Decl.declaration syntaxVersion + |> P.fmap (\( decl, _ ) -> P.Loop (decl :: decls)) + ) + ] + (P.Done (List.reverse decls)) + + +chompInfixes : List (Src.C1 (A.Located Src.Infix)) -> P.Parser E.Module (List (Src.C1 (A.Located Src.Infix))) +chompInfixes infixes = + P.oneOfWithFallback + [ Decl.infix_ + |> P.bind (\binop -> chompInfixes (binop :: infixes)) + ] + infixes + + + +-- MODULE DOC COMMENT + + +chompModuleDocCommentSpace : P.Parser E.Module (Src.C1 (Result A.Region Src.Comment)) +chompModuleDocCommentSpace = + P.addLocation (freshLine E.FreshLine) + |> P.bind + (\(A.At region beforeComments) -> + P.oneOfWithFallback + [ Space.docComment E.ImportStart E.ModuleSpace + |> P.bind + (\docComment -> + Space.chomp E.ModuleSpace + |> P.bind + (\afterComments -> + Space.checkFreshLine E.FreshLine + |> P.fmap + (\_ -> + ( beforeComments ++ afterComments + , Ok docComment + ) + ) + ) + ) + ] + ( beforeComments, Err region ) + ) + + + +-- HEADER + + +type alias Header = + { name : Src.C2 (A.Located Name.Name) + , effects : Effects + , exports : Src.C2 (A.Located Src.Exposing) + , docs : Result A.Region Src.Comment + } + + +defaultHeader : Header +defaultHeader = + { name = ( ( [], [] ), A.At A.zero Name.mainModule ) + , effects = NoEffects A.zero + , exports = ( ( [], [] ), A.At A.zero (Src.Open [] []) ) + , docs = Err A.zero + } + + +type Effects + = NoEffects A.Region + | Ports A.Region Src.FComments + | Manager A.Region Src.FComments (Src.C1 Src.Manager) + + +chompHeader : P.Parser E.Module (Src.C2 (Maybe Header)) +chompHeader = + freshLine E.FreshLine + |> P.bind + (\initialComments -> + P.getPosition + |> P.bind + (\start -> + P.oneOfWithFallback + [ -- module MyThing exposing (..) + Keyword.module_ E.ModuleProblem + |> P.bind (\_ -> P.getPosition) + |> P.bind + (\effectEnd -> + Space.chompAndCheckIndent E.ModuleSpace E.ModuleProblem + |> P.bind + (\beforeNameComments -> + P.addLocation (Var.moduleName E.ModuleName) + |> P.bind + (\name -> + Space.chompAndCheckIndent E.ModuleSpace E.ModuleProblem + |> P.bind + (\afterNameComments -> + Keyword.exposing_ E.ModuleProblem + |> P.bind (\_ -> Space.chompAndCheckIndent E.ModuleSpace E.ModuleProblem) + |> P.bind + (\afterExportsComments -> + P.addLocation (P.specialize E.ModuleExposing exposing_) + |> P.bind + (\exports -> + chompModuleDocCommentSpace + |> P.fmap + (\( headerComments, docComment ) -> + ( ( initialComments, headerComments ) + , Just <| + Header ( ( beforeNameComments, afterNameComments ), name ) + (NoEffects (A.Region start effectEnd)) + ( ( [], afterExportsComments ), exports ) + docComment + ) + ) + ) + ) + ) + ) + ) + ) + , -- port module MyThing exposing (..) + Keyword.port_ E.PortModuleProblem + |> P.bind (\_ -> Space.chompAndCheckIndent E.ModuleSpace E.PortModuleProblem) + |> P.bind + (\postPortComments -> + Keyword.module_ E.PortModuleProblem + |> P.bind (\_ -> P.getPosition) + |> P.bind + (\effectEnd -> + Space.chompAndCheckIndent E.ModuleSpace E.PortModuleProblem + |> P.bind + (\beforeNameComments -> + P.addLocation (Var.moduleName E.PortModuleName) + |> P.bind + (\name -> + Space.chompAndCheckIndent E.ModuleSpace E.PortModuleProblem + |> P.bind + (\afterNameComments -> + Keyword.exposing_ E.PortModuleProblem + |> P.bind (\_ -> Space.chompAndCheckIndent E.ModuleSpace E.PortModuleProblem) + |> P.bind + (\postExportsComments -> + P.addLocation (P.specialize E.PortModuleExposing exposing_) + |> P.bind + (\exports -> + chompModuleDocCommentSpace + |> P.fmap + (\( headerComments, docComment ) -> + ( ( initialComments, headerComments ) + , Just <| + Header ( ( beforeNameComments, afterNameComments ), name ) + (Ports (A.Region start effectEnd) postPortComments) + ( ( [], postExportsComments ), exports ) + docComment + ) + ) + ) + ) + ) + ) + ) + ) + ) + , -- effect module MyThing where { command = MyCmd } exposing (..) + Keyword.effect_ E.Effect + |> P.bind (\_ -> Space.chompAndCheckIndent E.ModuleSpace E.Effect) + |> P.bind + (\postEffectComments -> + Keyword.module_ E.Effect + |> P.bind (\_ -> P.getPosition) + |> P.bind + (\effectEnd -> + Space.chompAndCheckIndent E.ModuleSpace E.Effect + |> P.bind + (\beforeNameComments -> + P.addLocation (Var.moduleName E.ModuleName) + |> P.bind + (\name -> + Space.chompAndCheckIndent E.ModuleSpace E.Effect + |> P.bind + (\afterNameComments -> + Keyword.where_ E.Effect + |> P.bind (\_ -> Space.chompAndCheckIndent E.ModuleSpace E.Effect) + |> P.bind + (\postWhereComments -> + chompManager + |> P.bind + (\( beforeExportsComments, manager ) -> + Space.chompAndCheckIndent E.ModuleSpace E.Effect + |> P.bind + (\_ -> + Keyword.exposing_ E.Effect + |> P.bind (\_ -> Space.chompAndCheckIndent E.ModuleSpace E.Effect) + |> P.bind + (\afterExportsComments -> + P.addLocation (P.specialize (\_ -> E.Effect) exposing_) + |> P.bind + (\exports -> + chompModuleDocCommentSpace + |> P.fmap + (\( headerComments, docComment ) -> + ( ( initialComments, headerComments ) + , Just <| + Header ( ( beforeNameComments, afterNameComments ), name ) + (Manager (A.Region start effectEnd) postEffectComments ( postWhereComments, manager )) + ( ( beforeExportsComments, afterExportsComments ), exports ) + docComment + ) + ) + ) + ) + ) + ) + ) + ) + ) + ) + ) + ) + ] + -- default header + ( ( initialComments, [] ), Nothing ) + ) + ) + + +chompManager : P.Parser E.Module (Src.C1 Src.Manager) +chompManager = + P.word1 '{' E.Effect + |> P.bind (\_ -> spaces_em) + |> P.bind + (\postOpeningBracketComments -> + P.oneOf E.Effect + [ chompCommand + |> P.bind + (\cmd -> + spaces_em + |> P.bind + (\trailingComments -> + P.oneOf E.Effect + [ P.word1 '}' E.Effect + |> P.bind (\_ -> spaces_em) + |> P.fmap + (\postClosingBracketComments -> + ( postClosingBracketComments + , Src.Cmd ( ( postOpeningBracketComments, trailingComments ), cmd ) + ) + ) + , P.word1 ',' E.Effect + |> P.bind (\_ -> spaces_em) + |> P.bind + (\postCommaComments -> + chompSubscription + |> P.bind + (\sub -> + spaces_em + |> P.bind + (\preClosingBracketComments -> + P.word1 '}' E.Effect + |> P.bind (\_ -> spaces_em) + |> P.fmap + (\postClosingBracketComments -> + ( postClosingBracketComments + , Src.Fx + ( ( postOpeningBracketComments, trailingComments ), cmd ) + ( ( postCommaComments, preClosingBracketComments ), sub ) + ) + ) + ) + ) + ) + ] + ) + ) + , chompSubscription + |> P.bind + (\sub -> + spaces_em + |> P.bind + (\trailingComments -> + P.oneOf E.Effect + [ P.word1 '}' E.Effect + |> P.bind (\_ -> spaces_em) + |> P.fmap + (\postClosingBracketComments -> + ( postClosingBracketComments + , Src.Sub ( ( postOpeningBracketComments, trailingComments ), sub ) + ) + ) + , P.word1 ',' E.Effect + |> P.bind (\_ -> spaces_em) + |> P.bind + (\postCommaComments -> + chompCommand + |> P.bind + (\cmd -> + spaces_em + |> P.bind + (\preClosingBracketComments -> + P.word1 '}' E.Effect + |> P.bind (\_ -> spaces_em) + |> P.fmap + (\postClosingBracketComments -> + ( postClosingBracketComments + , Src.Fx + ( ( postCommaComments, preClosingBracketComments ), cmd ) + ( ( postOpeningBracketComments, trailingComments ), sub ) + ) + ) + ) + ) + ) + ] + ) + ) + ] + ) + + +chompCommand : P.Parser E.Module (Src.C2 (A.Located Name.Name)) +chompCommand = + Keyword.command_ E.Effect + |> P.bind (\_ -> spaces_em) + |> P.bind + (\beforeEqualComments -> + P.word1 '=' E.Effect + |> P.bind (\_ -> spaces_em) + |> P.bind + (\afterEqualComments -> + P.addLocation (Var.upper E.Effect) + |> P.fmap (\command -> ( ( beforeEqualComments, afterEqualComments ), command )) + ) + ) + + +chompSubscription : P.Parser E.Module (Src.C2 (A.Located Name.Name)) +chompSubscription = + Keyword.subscription_ E.Effect + |> P.bind (\_ -> spaces_em) + |> P.bind + (\beforeEqualComments -> + P.word1 '=' E.Effect + |> P.bind (\_ -> spaces_em) + |> P.bind + (\afterEqualComments -> + P.addLocation (Var.upper E.Effect) + |> P.fmap (\subscription -> ( ( beforeEqualComments, afterEqualComments ), subscription )) + ) + ) + + +spaces_em : P.Parser E.Module Src.FComments +spaces_em = + Space.chompAndCheckIndent E.ModuleSpace E.Effect + + + +-- IMPORTS + + +chompImports : List (Src.C1 Src.Import) -> P.Parser E.Module (List (Src.C1 Src.Import)) +chompImports is = + P.oneOfWithFallback + [ chompImport + |> P.bind (\i -> chompImports (i :: is)) + ] + (List.reverse is) + + +chompImport : P.Parser E.Module (Src.C1 Src.Import) +chompImport = + Keyword.import_ E.ImportStart + |> P.bind (\_ -> Space.chompAndCheckIndent E.ModuleSpace E.ImportIndentName) + |> P.bind + (\preNameComments -> + P.addLocation (Var.moduleName E.ImportName) + |> P.bind + (\((A.At (A.Region _ end) _) as name) -> + Space.chomp E.ModuleSpace + |> P.bind + (\trailingComments -> + P.oneOf E.ImportEnd + [ Space.checkFreshLine E.ImportEnd + |> P.fmap (\_ -> ( trailingComments, Src.Import ( preNameComments, name ) Nothing ( ( [], [] ), Src.Explicit (A.At A.zero []) ) )) + , Space.checkIndent end E.ImportEnd + |> P.bind + (\_ -> + P.oneOf E.ImportAs + [ chompAs ( preNameComments, name ) trailingComments + , chompExposing ( preNameComments, name ) Nothing [] trailingComments + ] + ) + ] + ) + ) + ) + + +chompAs : Src.C1 (A.Located Name.Name) -> Src.FComments -> P.Parser E.Module (Src.C1 Src.Import) +chompAs name trailingComments = + Keyword.as_ E.ImportAs + |> P.bind (\_ -> Space.chompAndCheckIndent E.ModuleSpace E.ImportIndentAlias) + |> P.bind + (\postAliasComments -> + Var.upper E.ImportAlias + |> P.bind + (\alias_ -> + P.getPosition + |> P.bind + (\end -> + Space.chomp E.ModuleSpace + |> P.bind + (\preExposedComments -> + P.oneOf E.ImportEnd + [ Space.checkFreshLine E.ImportEnd + |> P.fmap (\_ -> ( preExposedComments, Src.Import name (Just ( ( trailingComments, postAliasComments ), alias_ )) ( ( [], [] ), Src.Explicit (A.At A.zero []) ) )) + , Space.checkIndent end E.ImportEnd + |> P.bind (\_ -> chompExposing name (Just ( postAliasComments, alias_ )) trailingComments preExposedComments) + ] + ) + ) + ) + ) + + +chompExposing : Src.C1 (A.Located Name.Name) -> Maybe (Src.C1 Name.Name) -> Src.FComments -> Src.FComments -> P.Parser E.Module (Src.C1 Src.Import) +chompExposing name maybeAlias trailingComments preExposedComments = + Keyword.exposing_ E.ImportExposing + |> P.bind (\_ -> Space.chompAndCheckIndent E.ModuleSpace E.ImportIndentExposingList) + |> P.bind + (\postExposedComments -> + P.specialize E.ImportExposingList exposing_ + |> P.bind + (\exposed -> + freshLine E.ImportEnd + |> P.fmap (\comments -> ( comments, Src.Import name (Maybe.map (\( postAliasComments, alias_ ) -> ( ( trailingComments, postAliasComments ), alias_ )) maybeAlias) ( ( preExposedComments, postExposedComments ), exposed ) )) + ) + ) + + + +-- LISTING + + +exposing_ : P.Parser E.Exposing Src.Exposing +exposing_ = + P.word1 '(' E.ExposingStart + |> P.bind (\_ -> P.getPosition) + |> P.bind + (\start -> + Space.chompAndCheckIndent E.ExposingSpace E.ExposingIndentValue + |> P.bind + (\preExposedComments -> + P.oneOf E.ExposingValue + [ P.word2 '.' '.' E.ExposingValue + |> P.bind (\_ -> Space.chompAndCheckIndent E.ExposingSpace E.ExposingIndentEnd) + |> P.bind + (\postComments -> + P.word1 ')' E.ExposingEnd + |> P.fmap (\_ -> Src.Open preExposedComments postComments) + ) + , chompExposed + |> P.bind + (\exposed -> + Space.chompAndCheckIndent E.ExposingSpace E.ExposingIndentEnd + |> P.bind + (\postExposedComments -> + P.loop (exposingHelp start) [ ( ( preExposedComments, postExposedComments ), exposed ) ] + ) + ) + ] + ) + ) + + +exposingHelp : A.Position -> List (Src.C2 Src.Exposed) -> P.Parser E.Exposing (P.Step (List (Src.C2 Src.Exposed)) Src.Exposing) +exposingHelp start revExposed = + P.oneOf E.ExposingEnd + [ P.word1 ',' E.ExposingEnd + |> P.bind (\_ -> Space.chompAndCheckIndent E.ExposingSpace E.ExposingIndentValue) + |> P.bind + (\preExposedComments -> + chompExposed + |> P.bind + (\exposed -> + Space.chompAndCheckIndent E.ExposingSpace E.ExposingIndentEnd + |> P.fmap + (\postExposedComments -> + P.Loop (( ( preExposedComments, postExposedComments ), exposed ) :: revExposed) + ) + ) + ) + , P.word1 ')' E.ExposingEnd + |> P.bind (\_ -> P.getPosition) + |> P.fmap (\end -> P.Done (Src.Explicit (A.At (A.Region start end) (List.reverse revExposed)))) + ] + + +chompExposed : P.Parser E.Exposing Src.Exposed +chompExposed = + P.getPosition + |> P.bind + (\start -> + P.oneOf E.ExposingValue + [ Var.lower E.ExposingValue + |> P.bind + (\name -> + P.getPosition + |> P.fmap (\end -> Src.Lower <| A.at start end name) + ) + , P.word1 '(' E.ExposingValue + |> P.bind (\_ -> Symbol.operator E.ExposingOperator E.ExposingOperatorReserved) + |> P.bind + (\op -> + P.word1 ')' E.ExposingOperatorRightParen + |> P.bind (\_ -> P.getPosition) + |> P.fmap (\end -> Src.Operator (A.Region start end) op) + ) + , Var.upper E.ExposingValue + |> P.bind + (\name -> + P.getPosition + |> P.bind + (\end -> + Space.chompAndCheckIndent E.ExposingSpace E.ExposingIndentEnd + |> P.bind + (\privacyComments -> + privacy + |> P.fmap (Src.Upper (A.at start end name) << Tuple.pair privacyComments) + ) + ) + ) + ] + ) + + +privacy : P.Parser E.Exposing Src.Privacy +privacy = + P.oneOfWithFallback + [ P.word1 '(' E.ExposingTypePrivacy + |> P.bind (\_ -> Space.chompAndCheckIndent E.ExposingSpace E.ExposingTypePrivacy) + |> P.bind (\_ -> P.getPosition) + |> P.bind + (\start -> + P.word2 '.' '.' E.ExposingTypePrivacy + |> P.bind (\_ -> P.getPosition) + |> P.bind + (\end -> + Space.chompAndCheckIndent E.ExposingSpace E.ExposingTypePrivacy + |> P.bind (\_ -> P.word1 ')' E.ExposingTypePrivacy) + |> P.fmap (\_ -> Src.Public (A.Region start end)) + ) + ) + ] + Src.Private diff --git a/src/Compiler/Parse/Number.elm b/src/Compiler/Parse/Number.elm new file mode 100644 index 0000000000..ac69003be8 --- /dev/null +++ b/src/Compiler/Parse/Number.elm @@ -0,0 +1,641 @@ +module Compiler.Parse.Number exposing + ( Number(..) + , Outcome(..) + , chompHex + , number + , precedence + ) + +import Compiler.AST.Utils.Binop as Binop +import Compiler.Parse.Primitives as P exposing (Col, Row) +import Compiler.Parse.SyntaxVersion as SV exposing (SyntaxVersion) +import Compiler.Parse.Variable as Var +import Compiler.Reporting.Error.Syntax as E + + + +-- HELPERS + + +isDirtyEnd : String -> Int -> Int -> Char -> Bool +isDirtyEnd src pos end word = + Var.getInnerWidthHelp src pos end word > 0 + + +isDecimalDigit : Char -> Bool +isDecimalDigit word = + Char.isDigit word + + + +-- NUMBERS + + +type Number + = Int Int String + | Float Float String + + +number : SyntaxVersion -> (Row -> Col -> x) -> (E.Number -> Row -> Col -> x) -> P.Parser x Number +number syntaxVersion toExpectation toError = + P.Parser <| + \(P.State src pos end indent row col) -> + if pos >= end then + P.Eerr row col toExpectation + + else + let + word : Char + word = + charAtPos pos src + in + if word == '_' && syntaxVersion == SV.Guida then + P.Cerr row col (toError E.NumberNoLeadingOrTrailingUnderscores) + + else if not (isDecimalDigit word) then + P.Eerr row col toExpectation + + else + let + outcome : Outcome + outcome = + if word == '0' then + chompZero syntaxVersion src (pos + 1) end + + else + chompInt syntaxVersion src (pos + 1) end (Char.toCode word - Char.toCode '0') + in + case outcome of + Err_ newPos problem -> + let + newCol : Col + newCol = + col + (newPos - pos) + in + P.Cerr row newCol (toError problem) + + OkInt newPos n -> + let + newCol : Col + newCol = + col + (newPos - pos) + + integer : Number + integer = + Int n (String.slice pos newPos src) + + newState : P.State + newState = + P.State src newPos end indent row newCol + in + P.Cok integer newState + + OkFloat newPos -> + let + newCol : Col + newCol = + col + (newPos - pos) + + raw : String + raw = + String.slice pos newPos src + + parsed : Maybe Float + parsed = + if syntaxVersion == SV.Guida then + String.replace "_" "" raw + |> String.toFloat + + else + String.toFloat raw + in + case parsed of + Just copy_ -> + let + newState : P.State + newState = + P.State src newPos end indent row newCol + in + P.Cok (Float copy_ raw) newState + + Nothing -> + P.Eerr row newCol toExpectation + + + +-- CHOMP OUTCOME + + +type Outcome + = Err_ Int E.Number + | OkInt Int Int + | OkFloat Int + + + +-- CHOMP INT + + +chompInt : SyntaxVersion -> String -> Int -> Int -> Int -> Outcome +chompInt syntaxVersion src pos end n = + if pos >= end then + OkInt pos n + + else + let + word : Char + word = + charAtPos pos src + in + if isDecimalDigit word then + chompInt syntaxVersion src (pos + 1) end (10 * n + (Char.toCode word - Char.toCode '0')) + + else if word == '.' then + chompFraction syntaxVersion src pos end n + + else if word == 'e' || word == 'E' then + chompExponent syntaxVersion src (pos + 1) end + + else if word == '_' && syntaxVersion == SV.Guida then + chompUnderscore_ syntaxVersion src pos end n + + else if isDirtyEnd src pos end word then + Err_ pos E.NumberEnd + + else + OkInt pos n + + + +-- CHOMP UNDERSCORE + + +chompUnderscore_ : SyntaxVersion -> String -> Int -> Int -> Int -> Outcome +chompUnderscore_ syntaxVersion src pos end n = + if pos >= end then + Err_ pos E.NumberNoLeadingOrTrailingUnderscores + + else + let + nextWord : Char + nextWord = + charAtPos (pos + 1) src + in + if nextWord == '_' then + Err_ (pos + 1) E.NumberNoConsecutiveUnderscores + + else if nextWord == 'e' || nextWord == 'E' then + Err_ pos E.NumberNoUnderscoresAdjacentToDecimalOrExponent + + else if nextWord == '.' then + Err_ pos E.NumberNoUnderscoresAdjacentToDecimalOrExponent + + else if isDecimalDigit nextWord then + chompUnderscoreHelp syntaxVersion src (pos + 1) end n + + else + Err_ pos (E.NumberDot n) + + +chompUnderscoreHelp : SyntaxVersion -> String -> Int -> Int -> Int -> Outcome +chompUnderscoreHelp syntaxVersion src pos end n = + if pos >= end then + OkInt pos n + + else + let + word : Char + word = + charAtPos pos src + in + if word == '_' then + let + nextWord : Char + nextWord = + charAtPos (pos + 1) src + in + if nextWord == '_' then + Err_ (pos + 1) E.NumberNoConsecutiveUnderscores + + else if nextWord == 'e' || nextWord == 'E' || nextWord == '.' then + Err_ pos E.NumberNoUnderscoresAdjacentToDecimalOrExponent + + else if pos + 1 == end then + Err_ pos E.NumberNoLeadingOrTrailingUnderscores + + else + chompUnderscoreHelp syntaxVersion src (pos + 1) end n + + else if word == '.' then + chompFraction syntaxVersion src pos end n + + else if isDecimalDigit word then + chompUnderscoreHelp syntaxVersion src (pos + 1) end (10 * n + (Char.toCode word - Char.toCode '0')) + + else + OkInt pos n + + + +-- CHOMP FRACTION + + +chompFraction : SyntaxVersion -> String -> Int -> Int -> Int -> Outcome +chompFraction syntaxVersion src pos end n = + let + pos1 : Int + pos1 = + pos + 1 + in + if pos1 >= end then + Err_ pos (E.NumberDot n) + + else + let + nextWord : Char + nextWord = + charAtPos pos1 src + in + if nextWord == '_' && syntaxVersion == SV.Guida then + Err_ (pos + 1) E.NumberNoUnderscoresAdjacentToDecimalOrExponent + + else if isDecimalDigit nextWord then + chompFractionHelp syntaxVersion src (pos1 + 1) end + + else + Err_ pos (E.NumberDot n) + + +chompFractionHelp : SyntaxVersion -> String -> Int -> Int -> Outcome +chompFractionHelp syntaxVersion src pos end = + if pos >= end then + OkFloat pos + + else + let + word : Char + word = + charAtPos pos src + in + if isDecimalDigit word then + chompFractionHelp syntaxVersion src (pos + 1) end + + else if word == '_' && syntaxVersion == SV.Guida then + if (pos + 1) == end then + Err_ pos E.NumberNoLeadingOrTrailingUnderscores + + else + let + nextWord : Char + nextWord = + charAtPos (pos + 1) src + in + if nextWord == '_' then + Err_ (pos + 1) E.NumberNoConsecutiveUnderscores + + else if nextWord == 'e' || nextWord == 'E' then + Err_ pos E.NumberNoUnderscoresAdjacentToDecimalOrExponent + + else + chompFractionHelp syntaxVersion src (pos + 1) end + + else if word == 'e' || word == 'E' then + chompExponent syntaxVersion src (pos + 1) end + + else if isDirtyEnd src pos end word then + Err_ pos E.NumberEnd + + else + OkFloat pos + + + +-- CHOMP EXPONENT + + +chompExponent : SyntaxVersion -> String -> Int -> Int -> Outcome +chompExponent syntaxVersion src pos end = + if pos >= end then + Err_ pos E.NumberEnd + + else + let + word : Char + word = + charAtPos pos src + in + if isDecimalDigit word then + chompExponentHelp syntaxVersion src (pos + 1) end + + else if word == '_' && syntaxVersion == SV.Guida then + Err_ pos E.NumberNoUnderscoresAdjacentToDecimalOrExponent + + else if word == '+' || word == '-' then + let + pos1 : Int + pos1 = + pos + 1 + + nextWord : Char + nextWord = + charAtPos pos1 src + in + if nextWord == '_' && syntaxVersion == SV.Guida then + Err_ (pos + 1) E.NumberNoUnderscoresAdjacentToDecimalOrExponent + + else if pos1 < end && isDecimalDigit nextWord then + chompExponentHelp syntaxVersion src (pos + 2) end + + else + Err_ pos E.NumberEnd + + else + Err_ pos E.NumberEnd + + +chompExponentHelp : SyntaxVersion -> String -> Int -> Int -> Outcome +chompExponentHelp syntaxVersion src pos end = + if pos >= end then + OkFloat pos + + else + let + word : Char + word = + charAtPos pos src + in + if isDecimalDigit word || (word == '_' && syntaxVersion == SV.Guida) then + chompExponentHelp syntaxVersion src (pos + 1) end + + else + OkFloat pos + + + +-- CHOMP ZERO + + +chompZero : SyntaxVersion -> String -> Int -> Int -> Outcome +chompZero syntaxVersion src pos end = + if pos >= end then + OkInt pos 0 + + else + let + word : Char + word = + charAtPos pos src + in + if word == 'x' then + if charAtPos (pos + 1) src == '_' && syntaxVersion == SV.Guida then + Err_ (pos + 1) E.NumberNoUnderscoresAdjacentToHexadecimalPreFix + + else + chompHexInt syntaxVersion src (pos + 1) end + + else if word == 'b' && syntaxVersion == SV.Guida then + if charAtPos (pos + 1) src == '_' then + Err_ (pos + 1) E.NumberNoUnderscoresAdjacentToBinaryPreFix + + else + chompBinInt src (pos + 1) end + + else if word == '.' then + chompFraction syntaxVersion src pos end 0 + + else if isDecimalDigit word then + Err_ pos E.NumberNoLeadingZero + + else if isDirtyEnd src pos end word then + Err_ pos E.NumberEnd + + else + OkInt pos 0 + + +chompHexInt : SyntaxVersion -> String -> Int -> Int -> Outcome +chompHexInt syntaxVersion src pos end = + let + ( newPos, answer ) = + chompHex syntaxVersion src pos end + in + if answer == -4 then + Err_ (newPos + 1) E.NumberNoConsecutiveUnderscores + + else if answer == -3 then + Err_ newPos E.NumberNoLeadingOrTrailingUnderscores + + else if answer < 0 then + Err_ newPos E.NumberHexDigit + + else + OkInt newPos answer + + +chompBinInt : String -> Int -> Int -> Outcome +chompBinInt src pos end = + let + ( newPos, answer ) = + chompBin src pos end + in + if answer == -4 then + Err_ (newPos + 1) E.NumberNoConsecutiveUnderscores + + else if answer == -3 then + Err_ newPos E.NumberNoLeadingOrTrailingUnderscores + + else if answer < 0 then + Err_ newPos E.NumberBinDigit + + else + OkInt newPos answer + + + +-- CHOMP HEX + + +chompHex : SyntaxVersion -> String -> Int -> Int -> ( Int, Int ) +chompHex syntaxVersion src pos end = + chompHexHelp syntaxVersion src pos end -1 0 + + +chompHexHelp : SyntaxVersion -> String -> Int -> Int -> Int -> Int -> ( Int, Int ) +chompHexHelp syntaxVersion src pos end answer accumulator = + if pos >= end then + ( pos, answer ) + + else + let + newAnswer : Int + newAnswer = + stepHex syntaxVersion src pos end (charAtPos pos src) accumulator + in + if newAnswer < 0 then + ( pos + , if newAnswer == -1 then + answer + + else if newAnswer == -3 then + -3 + + else if newAnswer == -4 then + -4 + + else + -2 + ) + + else + chompHexHelp syntaxVersion src (pos + 1) end newAnswer newAnswer + + +stepHex : SyntaxVersion -> String -> Int -> Int -> Char -> Int -> Int +stepHex syntaxVersion src pos end word acc = + if '0' <= word && word <= '9' then + 16 * acc + (Char.toCode word - Char.toCode '0') + + else if 'a' <= word && word <= 'f' then + 16 * acc + 10 + (Char.toCode word - Char.toCode 'a') + + else if 'A' <= word && word <= 'F' then + 16 * acc + 10 + (Char.toCode word - Char.toCode 'A') + + else if word == '_' && syntaxVersion == SV.Guida then + let + nextWord : Char + nextWord = + charAtPos (pos + 1) src + in + if nextWord == '_' then + -4 + + else + let + validNextWord : Bool + validNextWord = + ('0' <= nextWord && nextWord <= '9') + || ('a' <= nextWord && nextWord <= 'f') + || ('A' <= nextWord && nextWord <= 'F') + in + if pos + 1 == end || not validNextWord then + -3 + + else + acc + + else if isDirtyEnd src pos end word then + -2 + + else + -1 + + + +-- CHOMP BIN + + +chompBin : String -> Int -> Int -> ( Int, Int ) +chompBin src pos end = + chompBinHelp src pos end -1 0 + + +chompBinHelp : String -> Int -> Int -> Int -> Int -> ( Int, Int ) +chompBinHelp src pos end answer accumulator = + if pos >= end then + ( pos, answer ) + + else + let + newAnswer : Int + newAnswer = + stepBin src pos end (charAtPos pos src) accumulator + in + if newAnswer < 0 then + ( pos + , if newAnswer == -1 then + answer + + else if newAnswer == -3 then + -3 + + else if newAnswer == -4 then + -4 + + else + -2 + ) + + else + chompBinHelp src (pos + 1) end newAnswer newAnswer + + +stepBin : String -> Int -> Int -> Char -> Int -> Int +stepBin src pos end word acc = + if '0' <= word && word <= '1' then + 2 * acc + (Char.toCode word - Char.toCode '0') + + else if word == '_' then + let + nextWord : Char + nextWord = + charAtPos (pos + 1) src + in + if nextWord == '_' then + -4 + + else + let + validNextWord : Bool + validNextWord = + '0' <= nextWord && nextWord <= '1' + in + if pos + 1 == end || not validNextWord then + -3 + + else + acc + + else if isDirtyEnd src pos end word then + -2 + + else + -1 + + + +-- PRECEDENCE + + +precedence : (Row -> Col -> x) -> P.Parser x Binop.Precedence +precedence toExpectation = + P.Parser <| + \(P.State src pos end indent row col) -> + if pos >= end then + P.Eerr row col toExpectation + + else + let + word : Char + word = + charAtPos pos src + in + if isDecimalDigit word then + P.Cok + (Char.toCode word - Char.toCode '0') + (P.State src (pos + 1) end indent row (col + 1)) + + else + P.Eerr row col toExpectation + + + +-- CHAR AT POSITION + + +charAtPos : Int -> String -> Char +charAtPos pos src = + String.dropLeft pos src + |> String.uncons + |> Maybe.map Tuple.first + |> Maybe.withDefault ' ' diff --git a/src/Compiler/Parse/Pattern.elm b/src/Compiler/Parse/Pattern.elm new file mode 100644 index 0000000000..e61eb83736 --- /dev/null +++ b/src/Compiler/Parse/Pattern.elm @@ -0,0 +1,415 @@ +module Compiler.Parse.Pattern exposing + ( expression + , term + ) + +import Compiler.AST.Source as Src +import Compiler.Data.Name as Name +import Compiler.Parse.Keyword as Keyword +import Compiler.Parse.Number as Number +import Compiler.Parse.Primitives as P +import Compiler.Parse.Space as Space +import Compiler.Parse.String as String +import Compiler.Parse.SyntaxVersion as SV exposing (SyntaxVersion) +import Compiler.Parse.Variable as Var +import Compiler.Reporting.Annotation as A +import Compiler.Reporting.Error.Syntax as E + + + +-- TERM + + +term : SyntaxVersion -> P.Parser E.Pattern Src.Pattern +term syntaxVersion = + P.getPosition + |> P.bind + (\start -> + P.oneOf E.PStart + [ record start + , tuple syntaxVersion start + , list syntaxVersion start + , termHelp syntaxVersion start + ] + ) + + +termHelp : SyntaxVersion -> A.Position -> P.Parser E.Pattern Src.Pattern +termHelp syntaxVersion start = + P.oneOf E.PStart + [ wildcard syntaxVersion + |> P.bind (\name -> P.addEnd start (Src.PAnything name)) + , Var.lower E.PStart + |> P.bind (\name -> P.addEnd start (Src.PVar name)) + , Var.foreignUpper E.PStart + |> P.bind + (\upper -> + P.getPosition + |> P.fmap + (\end -> + let + region : A.Region + region = + A.Region start end + in + A.at start end <| + case upper of + Var.Unqualified name -> + Src.PCtor region name [] + + Var.Qualified home name -> + Src.PCtorQual region home name [] + ) + ) + , Number.number syntaxVersion E.PStart E.PNumber + |> P.bind + (\number -> + P.getPosition + |> P.bind + (\end -> + case number of + Number.Int int src -> + P.pure (A.at start end (Src.PInt int src)) + + Number.Float float _ -> + P.Parser <| + \(P.State _ _ _ _ row col) -> + let + width : Int + width = + String.fromFloat float + |> String.length + in + P.Cerr row (col - width) (E.PFloat width) + ) + ) + , String.string syntaxVersion E.PStart E.PString + |> P.bind (\( str, multiline ) -> P.addEnd start (Src.PStr str multiline)) + , String.character syntaxVersion E.PStart E.PChar + |> P.bind (\chr -> P.addEnd start (Src.PChr chr)) + ] + + + +-- WILDCARD + + +wildcard : SyntaxVersion -> P.Parser E.Pattern Name.Name +wildcard syntaxVersion = + P.Parser <| + \(P.State src pos end indent row col) -> + if pos == end || P.unsafeIndex src pos /= '_' then + P.Eerr row col E.PStart + + else + let + newPos : Int + newPos = + pos + 1 + + newCol : P.Col + newCol = + col + 1 + in + if Var.getInnerWidth src newPos end > 0 then + case syntaxVersion of + SV.Elm -> + let + ( badPos, badCol ) = + Var.chompInnerChars src newPos end newCol + in + P.Cerr row col (E.PWildcardNotVar (Name.fromPtr src pos badPos) (badCol - col)) + + SV.Guida -> + let + ( lowerPos, lowerCol ) = + Var.chompLower src newPos end newCol + + name : String + name = + Name.fromPtr src newPos lowerPos + in + if Var.isReservedWord name then + P.Cerr row col (E.PWildcardReservedWord (Name.fromPtr src newPos lowerPos) (lowerCol - col)) + + else + let + newState : P.State + newState = + P.State src lowerPos end indent row lowerCol + in + P.Cok name newState + + else + let + newState : P.State + newState = + P.State src newPos end indent row newCol + in + P.Cok "" newState + + + +-- RECORDS + + +record : A.Position -> P.Parser E.Pattern Src.Pattern +record start = + P.inContext E.PRecord (P.word1 '{' E.PStart) <| + (Space.chompAndCheckIndent E.PRecordSpace E.PRecordIndentOpen + |> P.bind + (\preVarComments -> + P.oneOf E.PRecordOpen + [ P.addLocation (Var.lower E.PRecordField) + |> P.bind + (\var -> + Space.chompAndCheckIndent E.PRecordSpace E.PRecordIndentEnd + |> P.bind + (\postVarComments -> + recordHelp start [ ( ( preVarComments, postVarComments ), var ) ] + ) + ) + , P.word1 '}' E.PRecordEnd + |> P.bind (\_ -> P.addEnd start (Src.PRecord ( preVarComments, [] ))) + ] + ) + ) + + +recordHelp : A.Position -> List (Src.C2 (A.Located Name.Name)) -> P.Parser E.PRecord Src.Pattern +recordHelp start vars = + P.oneOf E.PRecordEnd + [ P.word1 ',' E.PRecordEnd + |> P.bind (\_ -> Space.chompAndCheckIndent E.PRecordSpace E.PRecordIndentField) + |> P.bind + (\preVarComments -> + P.addLocation (Var.lower E.PRecordField) + |> P.bind + (\var -> + Space.chompAndCheckIndent E.PRecordSpace E.PRecordIndentEnd + |> P.bind + (\postVarComments -> + recordHelp start (( ( preVarComments, postVarComments ), var ) :: vars) + ) + ) + ) + , P.word1 '}' E.PRecordEnd + |> P.bind (\_ -> P.addEnd start (Src.PRecord ( [], vars ))) + ] + + + +-- TUPLES + + +tuple : SyntaxVersion -> A.Position -> P.Parser E.Pattern Src.Pattern +tuple syntaxVersion start = + P.inContext E.PTuple (P.word1 '(' E.PStart) <| + (Space.chompAndCheckIndent E.PTupleSpace E.PTupleIndentExpr1 + |> P.bind + (\prePatternComments -> + P.oneOf E.PTupleOpen + [ P.specialize E.PTupleExpr (expression syntaxVersion) + |> P.bind + (\( ( postPatternComments, pattern ), end ) -> + Space.checkIndent end E.PTupleIndentEnd + |> P.bind (\_ -> tupleHelp syntaxVersion start ( ( prePatternComments, postPatternComments ), pattern ) []) + ) + , P.word1 ')' E.PTupleEnd + |> P.bind (\_ -> P.addEnd start (Src.PUnit [])) + ] + ) + ) + + +tupleHelp : SyntaxVersion -> A.Position -> Src.C2 Src.Pattern -> List (Src.C2 Src.Pattern) -> P.Parser E.PTuple Src.Pattern +tupleHelp syntaxVersion start firstPattern revPatterns = + P.oneOf E.PTupleEnd + [ P.word1 ',' E.PTupleEnd + |> P.bind (\_ -> Space.chompAndCheckIndent E.PTupleSpace E.PTupleIndentExprN) + |> P.bind + (\prePatternComments -> + P.specialize E.PTupleExpr (expression syntaxVersion) + |> P.bind + (\( ( postPatternComments, pattern ), end ) -> + Space.checkIndent end E.PTupleIndentEnd + |> P.bind (\_ -> tupleHelp syntaxVersion start firstPattern (( ( prePatternComments, postPatternComments ), pattern ) :: revPatterns)) + ) + ) + , P.word1 ')' E.PTupleEnd + |> P.bind + (\_ -> + case List.reverse revPatterns of + [] -> + P.addEnd start (Src.PParens firstPattern) + + secondPattern :: otherPatterns -> + P.addEnd start (Src.PTuple firstPattern secondPattern otherPatterns) + ) + ] + + + +-- LIST + + +list : SyntaxVersion -> A.Position -> P.Parser E.Pattern Src.Pattern +list syntaxVersion start = + P.inContext E.PList (P.word1 '[' E.PStart) <| + (Space.chompAndCheckIndent E.PListSpace E.PListIndentOpen + |> P.bind + (\prePatternComments -> + P.oneOf E.PListOpen + [ P.specialize E.PListExpr (expression syntaxVersion) + |> P.bind + (\( ( postPatternComments, pattern ), end ) -> + Space.checkIndent end E.PListIndentEnd + |> P.bind (\_ -> listHelp syntaxVersion start [ ( ( prePatternComments, postPatternComments ), pattern ) ]) + ) + , P.word1 ']' E.PListEnd + |> P.bind (\_ -> P.addEnd start (Src.PList ( prePatternComments, [] ))) + ] + ) + ) + + +listHelp : SyntaxVersion -> A.Position -> List (Src.C2 Src.Pattern) -> P.Parser E.PList Src.Pattern +listHelp syntaxVersion start patterns = + P.oneOf E.PListEnd + [ P.word1 ',' E.PListEnd + |> P.bind (\_ -> Space.chompAndCheckIndent E.PListSpace E.PListIndentExpr) + |> P.bind + (\prePatternComments -> + P.specialize E.PListExpr (expression syntaxVersion) + |> P.bind + (\( ( postPatternComments, pattern ), end ) -> + Space.checkIndent end E.PListIndentEnd + |> P.bind (\_ -> listHelp syntaxVersion start (( ( prePatternComments, postPatternComments ), pattern ) :: patterns)) + ) + ) + , P.word1 ']' E.PListEnd + |> P.bind (\_ -> P.addEnd start (Src.PList ( [], List.reverse patterns ))) + ] + + + +-- EXPRESSION + + +expression : SyntaxVersion -> Space.Parser E.Pattern (Src.C1 Src.Pattern) +expression syntaxVersion = + P.getPosition + |> P.bind + (\start -> + exprPart syntaxVersion + |> P.bind + (\ePart -> + exprHelp syntaxVersion start [] ePart + ) + ) + + +exprHelp : SyntaxVersion -> A.Position -> List (Src.C2 Src.Pattern) -> ( Src.C1 Src.Pattern, A.Position ) -> Space.Parser E.Pattern (Src.C1 Src.Pattern) +exprHelp syntaxVersion start revPatterns ( ( prePatternComments, pattern ), end ) = + P.oneOfWithFallback + [ Space.checkIndent end E.PIndentStart + |> P.bind (\_ -> P.word2 ':' ':' E.PStart) + |> P.bind (\_ -> Space.chompAndCheckIndent E.PSpace E.PIndentStart) + |> P.bind + (\postPatternComments -> + exprPart syntaxVersion + |> P.bind (\ePart -> exprHelp syntaxVersion start (( ( prePatternComments, postPatternComments ), pattern ) :: revPatterns) ePart) + ) + , Space.checkIndent end E.PIndentStart + |> P.bind (\_ -> Keyword.as_ E.PStart) + |> P.bind (\_ -> Space.chompAndCheckIndent E.PSpace E.PIndentAlias) + |> P.bind + (\preAliasComments -> + P.getPosition + |> P.bind + (\nameStart -> + Var.lower E.PAlias + |> P.bind + (\name -> + P.getPosition + |> P.bind + (\newEnd -> + Space.chomp E.PSpace + |> P.fmap + (\postAliasComments -> + let + alias_ : A.Located Name.Name + alias_ = + A.at nameStart newEnd name + in + ( ( postAliasComments, A.at start newEnd (Src.PAlias ( prePatternComments, List.foldl cons pattern revPatterns ) ( preAliasComments, alias_ )) ) + , newEnd + ) + ) + ) + ) + ) + ) + ] + ( ( prePatternComments, List.foldl cons pattern revPatterns ) + , end + ) + + +cons : Src.C2 Src.Pattern -> Src.Pattern -> Src.Pattern +cons ( ( preComments, postComments ), hd ) tl = + A.merge hd tl (Src.PCons ( Nothing, hd ) ( ( preComments, postComments, Nothing ), tl )) + + + +-- EXPRESSION PART + + +exprPart : SyntaxVersion -> Space.Parser E.Pattern (Src.C1 Src.Pattern) +exprPart syntaxVersion = + P.oneOf E.PStart + [ P.getPosition + |> P.bind + (\start -> + Var.foreignUpper E.PStart + |> P.bind + (\upper -> + P.getPosition + |> P.bind (\end -> exprTermHelp syntaxVersion (A.Region start end) upper start []) + ) + ) + , term syntaxVersion + |> P.bind + (\((A.At (A.Region _ end) _) as eterm) -> + Space.chomp E.PSpace + |> P.fmap (\comments -> ( ( comments, eterm ), end )) + ) + ] + + +exprTermHelp : SyntaxVersion -> A.Region -> Var.Upper -> A.Position -> List (Src.C1 Src.Pattern) -> Space.Parser E.Pattern (Src.C1 Src.Pattern) +exprTermHelp syntaxVersion region upper start revArgs = + P.getPosition + |> P.bind + (\end -> + Space.chomp E.PSpace + |> P.bind + (\comments -> + P.oneOfWithFallback + [ Space.checkIndent end E.PIndentStart + |> P.bind (\_ -> term syntaxVersion) + |> P.bind (\arg -> exprTermHelp syntaxVersion region upper start (( [], arg ) :: revArgs)) + ] + ( ( comments + , A.at start end <| + case upper of + Var.Unqualified name -> + Src.PCtor region name (List.reverse revArgs) + + Var.Qualified home name -> + Src.PCtorQual region home name (List.reverse revArgs) + ) + , end + ) + ) + ) diff --git a/src/Compiler/Parse/Primitives.elm b/src/Compiler/Parse/Primitives.elm new file mode 100644 index 0000000000..91587d8659 --- /dev/null +++ b/src/Compiler/Parse/Primitives.elm @@ -0,0 +1,547 @@ +module Compiler.Parse.Primitives exposing + ( Col + , PStep(..) + , Parser(..) + , Row + , Snippet(..) + , State(..) + , Step(..) + , addEnd + , addLocation + , bind + , fmap + , fromByteString + , fromSnippet + , getCharWidth + , getPosition + , inContext + , isWord + , loop + , oneOf + , oneOfWithFallback + , pure + , snippetDecoder + , snippetEncoder + , specialize + , unsafeIndex + , withBacksetIndent + , withIndent + , word1 + , word2 + ) + +import Compiler.Reporting.Annotation as A +import Utils.Bytes.Decode as BD +import Utils.Bytes.Encode as BE +import Utils.Crash exposing (crash) + + + +-- PARSER + + +type Parser x a + = Parser (State -> PStep x a) + + +type PStep x a + = Cok a State + | Eok a State + | Cerr Row Col (Row -> Col -> x) + | Eerr Row Col (Row -> Col -> x) + + +type State + = -- PERF try taking some out to avoid allocation + State String Int Int Int Row Col + + +type alias Row = + Int + + +type alias Col = + Int + + + +-- FUNCTOR + + +fmap : (a -> b) -> Parser x a -> Parser x b +fmap f (Parser parser) = + Parser + (\state -> + case parser state of + Cok a s -> + Cok (f a) s + + Eok a s -> + Eok (f a) s + + Cerr r c t -> + Cerr r c t + + Eerr r c t -> + Eerr r c t + ) + + + +-- ONE OF + + +oneOf : (Row -> Col -> x) -> List (Parser x a) -> Parser x a +oneOf toError parsers = + Parser + (\state -> + oneOfHelp state toError parsers + ) + + +oneOfHelp : State -> (Row -> Col -> x) -> List (Parser x a) -> PStep x a +oneOfHelp state toError parsers = + case parsers of + (Parser parser) :: remainingParsers -> + case parser state of + Eerr _ _ _ -> + oneOfHelp state toError remainingParsers + + result -> + result + + [] -> + let + (State _ _ _ _ row col) = + state + in + Eerr row col toError + + + +-- ONE OF WITH FALLBACK + + +oneOfWithFallback : List (Parser x a) -> a -> Parser x a +oneOfWithFallback parsers fallback = + Parser (\state -> oowfHelp state parsers fallback) + + +oowfHelp : State -> List (Parser x a) -> a -> PStep x a +oowfHelp state parsers fallback = + case parsers of + [] -> + Eok fallback state + + (Parser parser) :: remainingParsers -> + case parser state of + Eerr _ _ _ -> + oowfHelp state remainingParsers fallback + + result -> + result + + + +-- MONAD + + +pure : a -> Parser x a +pure value = + Parser (\state -> Eok value state) + + +bind : (a -> Parser x b) -> Parser x a -> Parser x b +bind callback (Parser parserA) = + Parser + (\state -> + case parserA state of + Cok a s -> + case callback a of + Parser parserB -> + case parserB s of + Cok a_ s_ -> + Cok a_ s_ + + Eok a_ s_ -> + Cok a_ s_ + + result -> + result + + Eok a s -> + case callback a of + Parser parserB -> + parserB s + + Cerr r c t -> + Cerr r c t + + Eerr r c t -> + Eerr r c t + ) + + + +-- FROM BYTESTRING + + +fromByteString : Parser x a -> (Row -> Col -> x) -> String -> Result x a +fromByteString (Parser parser) toBadEnd src = + let + initialState : State + initialState = + State src 0 (String.length src) 0 1 1 + in + case parser initialState of + Cok a state -> + toOk toBadEnd a state + + Eok a state -> + toOk toBadEnd a state + + Cerr row col toError -> + toErr row col toError + + Eerr row col toError -> + toErr row col toError + + +toOk : (Row -> Col -> x) -> a -> State -> Result x a +toOk toBadEnd a (State _ pos end _ row col) = + if pos == end then + Ok a + + else + Err (toBadEnd row col) + + +toErr : Row -> Col -> (Row -> Col -> x) -> Result x a +toErr row col toError = + Err (toError row col) + + + +-- FROM SNIPPET + + +type Snippet + = Snippet + { fptr : String + , offset : Int + , length : Int + , offRow : Row + , offCol : Col + } + + +fromSnippet : Parser x a -> (Row -> Col -> x) -> Snippet -> Result x a +fromSnippet (Parser parser) toBadEnd (Snippet { fptr, offset, length, offRow, offCol }) = + let + initialState : State + initialState = + State fptr offset (offset + length) 0 offRow offCol + in + case parser initialState of + Cok a state -> + toOk toBadEnd a state + + Eok a state -> + toOk toBadEnd a state + + Cerr row col toError -> + toErr row col toError + + Eerr row col toError -> + toErr row col toError + + + +-- POSITION + + +getPosition : Parser x A.Position +getPosition = + Parser + (\((State _ _ _ _ row col) as state) -> + Eok (A.Position row col) state + ) + + +addLocation : Parser x a -> Parser x (A.Located a) +addLocation (Parser parser) = + Parser + (\((State _ _ _ _ sr sc) as state) -> + case parser state of + Cok a ((State _ _ _ _ er ec) as s) -> + Cok (A.At (A.Region (A.Position sr sc) (A.Position er ec)) a) s + + Eok a ((State _ _ _ _ er ec) as s) -> + Eok (A.At (A.Region (A.Position sr sc) (A.Position er ec)) a) s + + Cerr r c t -> + Cerr r c t + + Eerr r c t -> + Eerr r c t + ) + + +addEnd : A.Position -> a -> Parser x (A.Located a) +addEnd start value = + Parser + (\((State _ _ _ _ row col) as state) -> + Eok (A.at start (A.Position row col) value) state + ) + + + +-- INDENT + + +withIndent : Parser x a -> Parser x a +withIndent (Parser parser) = + Parser + (\(State src pos end oldIndent row col) -> + case parser (State src pos end col row col) of + Cok a (State s p e _ r c) -> + Cok a (State s p e oldIndent r c) + + Eok a (State s p e _ r c) -> + Eok a (State s p e oldIndent r c) + + err -> + err + ) + + +withBacksetIndent : Int -> Parser x a -> Parser x a +withBacksetIndent backset (Parser parser) = + Parser + (\(State src pos end oldIndent row col) -> + case parser (State src pos end (col - backset) row col) of + Cok a (State s p e _ r c) -> + Cok a (State s p e oldIndent r c) + + Eok a (State s p e _ r c) -> + Eok a (State s p e oldIndent r c) + + err -> + err + ) + + + +-- CONTEXT + + +inContext : (x -> Row -> Col -> y) -> Parser y start -> Parser x a -> Parser y a +inContext addContext (Parser parserStart) (Parser parserA) = + Parser + (\((State _ _ _ _ row col) as state) -> + case parserStart state of + Cok _ s -> + case parserA s of + Cok a s_ -> + Cok a s_ + + Eok a s_ -> + Cok a s_ + + Cerr r c tx -> + Cerr row col (addContext (tx r c)) + + Eerr r c tx -> + Cerr row col (addContext (tx r c)) + + Eok _ s -> + case parserA s of + Cok a s_ -> + Cok a s_ + + Eok a s_ -> + Eok a s_ + + Cerr r c tx -> + Cerr row col (addContext (tx r c)) + + Eerr r c tx -> + Eerr row col (addContext (tx r c)) + + Cerr r c t -> + Cerr r c t + + Eerr r c t -> + Eerr r c t + ) + + +specialize : (x -> Row -> Col -> y) -> Parser x a -> Parser y a +specialize addContext (Parser parser) = + Parser + (\((State _ _ _ _ row col) as state) -> + case parser state of + Cok a s -> + Cok a s + + Eok a s -> + Eok a s + + Cerr r c tx -> + Cerr row col (addContext (tx r c)) + + Eerr r c tx -> + Eerr row col (addContext (tx r c)) + ) + + + +-- SYMBOLS + + +word1 : Char -> (Row -> Col -> x) -> Parser x () +word1 word toError = + Parser + (\(State src pos end indent row col) -> + if pos < end && unsafeIndex src pos == word then + let + newState : State + newState = + State src (pos + 1) end indent row (col + 1) + in + Cok () newState + + else + Eerr row col toError + ) + + +word2 : Char -> Char -> (Row -> Col -> x) -> Parser x () +word2 w1 w2 toError = + Parser + (\(State src pos end indent row col) -> + let + pos1 : Int + pos1 = + pos + 1 + in + if pos1 < end && unsafeIndex src pos == w1 && unsafeIndex src pos1 == w2 then + let + newState : State + newState = + State src (pos + 2) end indent row (col + 2) + in + Cok () newState + + else + Eerr row col toError + ) + + + +-- LOW-LEVEL CHECKS + + +unsafeIndex : String -> Int -> Char +unsafeIndex str index = + case String.uncons (String.dropLeft index str) of + Just ( char, _ ) -> + char + + Nothing -> + crash "Error on unsafeIndex!" + + +isWord : String -> Int -> Int -> Char -> Bool +isWord src pos end word = + pos < end && unsafeIndex src pos == word + + +getCharWidth : Char -> Int +getCharWidth word = + if Char.toCode word > 0xFFFF then + 2 + + else + 1 + + + +-- ENCODERS and DECODERS + + +snippetEncoder : Snippet -> BE.Encoder +snippetEncoder (Snippet { fptr, offset, length, offRow, offCol }) = + BE.sequence + [ BE.string fptr + , BE.int offset + , BE.int length + , BE.int offRow + , BE.int offCol + ] + + +snippetDecoder : BD.Decoder Snippet +snippetDecoder = + BD.map5 + (\fptr offset length offRow offCol -> + Snippet + { fptr = fptr + , offset = offset + , length = length + , offRow = offRow + , offCol = offCol + } + ) + BD.string + BD.int + BD.int + BD.int + BD.int + + + +-- LOOP + + +type Step state a + = Loop state + | Done a + + +loop : (state -> Parser x (Step state a)) -> state -> Parser x a +loop callback loopState = + Parser + (\state -> + loopHelp callback state loopState Eok Eerr + ) + + +loopHelp : + (state -> Parser x (Step state a)) + -> State + -> state + -> (a -> State -> PStep x a) + -> (Row -> Col -> (Row -> Col -> x) -> PStep x a) + -> PStep x a +loopHelp callback state loopState eok eerr = + case callback loopState of + Parser parser -> + case parser state of + Cok (Loop newLoopState) newState -> + loopHelp callback newState newLoopState Cok Cerr + + Cok (Done a) newState -> + Cok a newState + + Eok (Loop newLoopState) newState -> + loopHelp callback newState newLoopState eok eerr + + Eok (Done a) newState -> + eok a newState + + Cerr r c t -> + Cerr r c t + + Eerr r c t -> + eerr r c t diff --git a/src/Compiler/Parse/Shader.elm b/src/Compiler/Parse/Shader.elm new file mode 100644 index 0000000000..fde64e836a --- /dev/null +++ b/src/Compiler/Parse/Shader.elm @@ -0,0 +1,240 @@ +module Compiler.Parse.Shader exposing (shader) + +import Compiler.AST.Source as Src +import Compiler.AST.Utils.Shader as Shader +import Compiler.Parse.Primitives as P exposing (Col, Parser, Row) +import Compiler.Reporting.Annotation as A +import Compiler.Reporting.Error.Syntax as E +import Data.Map as Dict +import Language.GLSL.Parser as GLP +import Language.GLSL.Syntax as GLS +import Utils.Crash as Crash + + + +-- SHADER + + +shader : A.Position -> Parser E.Expr Src.Expr +shader ((A.Position row col) as start) = + parseBlock + |> P.bind + (\block -> + parseGlsl row col block + |> P.bind + (\shdr -> + P.getPosition + |> P.fmap + (\end -> + A.at start end (Src.Shader (Shader.fromString block) shdr) + ) + ) + ) + + + +-- BLOCK + + +parseBlock : Parser E.Expr String +parseBlock = + P.Parser <| + \(P.State src pos end indent row col) -> + let + pos6 : Int + pos6 = + pos + 6 + in + if + (pos6 <= end) + && (P.unsafeIndex src pos == '[') + && (P.unsafeIndex src (pos + 1) == 'g') + && (P.unsafeIndex src (pos + 2) == 'l') + && (P.unsafeIndex src (pos + 3) == 's') + && (P.unsafeIndex src (pos + 4) == 'l') + && (P.unsafeIndex src (pos + 5) == '|') + then + let + ( ( status, newPos ), ( newRow, newCol ) ) = + eatShader src pos6 end row (col + 6) + in + case status of + Good -> + let + off : Int + off = + pos6 + + len : Int + len = + newPos - pos6 + + block : String + block = + String.left len (String.dropLeft off src) + + newState : P.State + newState = + P.State src (newPos + 2) end indent newRow (newCol + 2) + in + P.Cok block newState + + Unending -> + P.Cerr row col E.EndlessShader + + else + P.Eerr row col E.Start + + +type Status + = Good + | Unending + + +eatShader : String -> Int -> Int -> Row -> Col -> ( ( Status, Int ), ( Row, Col ) ) +eatShader src pos end row col = + if pos >= end then + ( ( Unending, pos ), ( row, col ) ) + + else + let + word : Char + word = + P.unsafeIndex src pos + in + if word == '|' && P.isWord src (pos + 1) end ']' then + ( ( Good, pos ), ( row, col ) ) + + else if word == '\n' then + eatShader src (pos + 1) end (row + 1) 1 + + else + let + newPos : Int + newPos = + pos + P.getCharWidth word + in + eatShader src newPos end row (col + 1) + + + +-- GLSL + + +parseGlsl : Row -> Col -> String -> Parser E.Expr Shader.Types +parseGlsl startRow startCol src = + case GLP.parse src of + Ok (GLS.TranslationUnit decls) -> + P.pure (List.foldr addInput emptyTypes (List.concatMap extractInputs decls)) + + Err { position, messages } -> + -- FIXME this should be moved into guida-lang/glsl + let + lines : List String + lines = + String.left position src + |> String.lines + + row : Int + row = + List.length lines + + col : Int + col = + case List.reverse lines of + lastLine :: _ -> + String.length lastLine + + _ -> + 0 + + msg : String + msg = + showErrorMessages messages + in + if row == 1 then + failure startRow (startCol + 6 + col) msg + + else + failure (startRow + row - 1) col msg + + +showErrorMessages : List String -> String +showErrorMessages msgs = + if List.isEmpty msgs then + "unknown parse error" + + else + String.join "\n" msgs + + +failure : Row -> Col -> String -> Parser E.Expr a +failure row col msg = + P.Parser <| + \_ -> + P.Cerr row col (E.ShaderProblem msg) + + + +-- INPUTS + + +emptyTypes : Shader.Types +emptyTypes = + Shader.Types Dict.empty Dict.empty Dict.empty + + +addInput : ( GLS.StorageQualifier, Shader.Type, String ) -> Shader.Types -> Shader.Types +addInput ( qual, tipe, name ) (Shader.Types attribute uniform varying) = + case qual of + GLS.Attribute -> + Shader.Types (Dict.insert identity name tipe attribute) uniform varying + + GLS.Uniform -> + Shader.Types attribute (Dict.insert identity name tipe uniform) varying + + GLS.Varying -> + Shader.Types attribute uniform (Dict.insert identity name tipe varying) + + _ -> + Crash.crash "Should never happen due to `extractInputs` function" + + +extractInputs : GLS.ExternalDeclaration -> List ( GLS.StorageQualifier, Shader.Type, String ) +extractInputs decl = + case decl of + GLS.Declaration (GLS.InitDeclaration (GLS.TypeDeclarator (GLS.FullType (Just (GLS.TypeQualSto qual)) (GLS.TypeSpec _ (GLS.TypeSpecNoPrecision tipe _)))) [ GLS.InitDecl name _ _ ]) -> + if List.member qual [ GLS.Attribute, GLS.Varying, GLS.Uniform ] then + case tipe of + GLS.Vec2 -> + [ ( qual, Shader.V2, name ) ] + + GLS.Vec3 -> + [ ( qual, Shader.V3, name ) ] + + GLS.Vec4 -> + [ ( qual, Shader.V4, name ) ] + + GLS.Mat4 -> + [ ( qual, Shader.M4, name ) ] + + GLS.Int -> + [ ( qual, Shader.Int, name ) ] + + GLS.Float -> + [ ( qual, Shader.Float, name ) ] + + GLS.Sampler2D -> + [ ( qual, Shader.Texture, name ) ] + + GLS.Bool -> + [ ( qual, Shader.Bool, name ) ] + + _ -> + [] + + else + [] + + _ -> + [] diff --git a/src/Compiler/Parse/Space.elm b/src/Compiler/Parse/Space.elm new file mode 100644 index 0000000000..4112c4c939 --- /dev/null +++ b/src/Compiler/Parse/Space.elm @@ -0,0 +1,363 @@ +module Compiler.Parse.Space exposing + ( Parser + , checkAligned + , checkFreshLine + , checkIndent + , chomp + , chompAndCheckIndent + , docComment + ) + +import Compiler.AST.Source as Src +import Compiler.Parse.Primitives as P exposing (Col, Row) +import Compiler.Reporting.Annotation as A +import Compiler.Reporting.Error.Syntax as E + + + +-- SPACE PARSING + + +type alias Parser x a = + P.Parser x ( a, A.Position ) + + + +-- CHOMP + + +chomp : (E.Space -> Row -> Col -> x) -> P.Parser x Src.FComments +chomp toError = + P.Parser <| + \(P.State src pos end indent row col) -> + let + ( ( status, comments, newPos ), ( newRow, newCol ) ) = + eat EatSpaces [] src pos end row col + in + case status of + Good -> + let + newState : P.State + newState = + P.State src newPos end indent newRow newCol + in + P.Cok (List.reverse comments) newState + + HasTab -> + P.Cerr newRow newCol (toError E.HasTab) + + EndlessMultiComment -> + P.Cerr newRow newCol (toError E.EndlessMultiComment) + + + +-- CHECKS -- to be called right after a `chomp` + + +checkIndent : A.Position -> (Int -> Int -> x) -> P.Parser x () +checkIndent (A.Position endRow endCol) toError = + P.Parser <| + \((P.State _ _ _ indent _ col) as state) -> + if col > indent && col > 1 then + P.Eok () state + + else + P.Eerr endRow endCol toError + + +checkAligned : (Int -> Int -> Int -> x) -> P.Parser x () +checkAligned toError = + P.Parser <| + \((P.State _ _ _ indent row col) as state) -> + if col == indent then + P.Eok () state + + else + P.Eerr row col (toError indent) + + +checkFreshLine : (Row -> Col -> x) -> P.Parser x () +checkFreshLine toError = + P.Parser <| + \((P.State _ _ _ _ row col) as state) -> + if col == 1 then + P.Eok () state + + else + P.Eerr row col toError + + + +-- CHOMP AND CHECK + + +chompAndCheckIndent : (E.Space -> Row -> Col -> x) -> (Row -> Col -> x) -> P.Parser x Src.FComments +chompAndCheckIndent toSpaceError toIndentError = + P.Parser <| + \(P.State src pos end indent row col) -> + let + ( ( status, comments, newPos ), ( newRow, newCol ) ) = + eat EatSpaces [] src pos end row col + in + case status of + Good -> + if newCol > indent && newCol > 1 then + let + newState : P.State + newState = + P.State src newPos end indent newRow newCol + in + P.Cok (List.reverse comments) newState + + else + P.Cerr row col toIndentError + + HasTab -> + P.Cerr newRow newCol (toSpaceError E.HasTab) + + EndlessMultiComment -> + P.Cerr newRow newCol (toSpaceError E.EndlessMultiComment) + + + +{- EAT SPACES, LINE COMMENTS AND MULTI COMMENTS + + This function combines the functionality of the original `eatSpaces`, `eatLineComment`, + and `eatMultiComment` methods. The merge resolves a "RangeError: Maximum call stack size exceeded" + issue reported in guida-lang/compiler#53. +-} + + +type EatType + = EatSpaces + | EatLineComment Int + | EatMultiComment + + +type Status + = Good + | HasTab + | EndlessMultiComment + + +eat : EatType -> Src.FComments -> String -> Int -> Int -> Row -> Col -> ( ( Status, Src.FComments, Int ), ( Row, Col ) ) +eat eatType comments src pos end row col = + case eatType of + EatSpaces -> + if pos >= end then + ( ( Good, comments, pos ), ( row, col ) ) + + else + case P.unsafeIndex src pos of + ' ' -> + eat EatSpaces comments src (pos + 1) end row (col + 1) + + '\n' -> + eat EatSpaces comments src (pos + 1) end (row + 1) 1 + + '{' -> + eat EatMultiComment comments src pos end row col + + '-' -> + let + pos1 : Int + pos1 = + pos + 1 + in + if pos1 < end && P.unsafeIndex src pos1 == '-' then + eat (EatLineComment (pos + 2)) comments src (pos + 2) end row (col + 2) + + else + ( ( Good, comments, pos ), ( row, col ) ) + + '\u{000D}' -> + eat EatSpaces comments src (pos + 1) end row col + + '\t' -> + ( ( HasTab, comments, pos ), ( row, col ) ) + + _ -> + ( ( Good, comments, pos ), ( row, col ) ) + + EatLineComment startPos -> + if pos >= end then + let + newComment : Src.FComment + newComment = + Src.LineComment (String.slice startPos pos src) + in + ( ( Good, newComment :: comments, pos ), ( row, col ) ) + + else + let + word : Char + word = + P.unsafeIndex src pos + in + if word == '\n' then + let + newComment : Src.FComment + newComment = + Src.LineComment (String.slice startPos pos src) + in + eat EatSpaces (newComment :: comments) src (pos + 1) end (row + 1) 1 + + else + let + newPos : Int + newPos = + pos + P.getCharWidth word + in + eat (EatLineComment startPos) comments src newPos end row (col + 1) + + EatMultiComment -> + let + pos2 : Int + pos2 = + pos + 2 + in + if pos2 >= end then + ( ( Good, comments, pos ), ( row, col ) ) + + else + let + pos1 : Int + pos1 = + pos + 1 + in + if P.unsafeIndex src pos1 == '-' then + if P.unsafeIndex src pos2 == '|' then + ( ( Good, comments, pos ), ( row, col ) ) + + else + let + ( ( status, newPos ), ( newRow, newCol ) ) = + eatMultiCommentHelp src pos2 end row (col + 2) 1 + in + case status of + MultiGood -> + let + newComment : Src.FComment + newComment = + Src.BlockComment (String.lines (String.slice pos2 (newPos - 2) src)) + in + eat EatSpaces (newComment :: comments) src newPos end newRow newCol + + MultiTab -> + ( ( HasTab, comments, newPos ), ( newRow, newCol ) ) + + MultiEndless -> + ( ( EndlessMultiComment, comments, pos ), ( row, col ) ) + + else + ( ( Good, comments, pos ), ( row, col ) ) + + +type MultiStatus + = MultiGood + | MultiTab + | MultiEndless + + +eatMultiCommentHelp : String -> Int -> Int -> Row -> Col -> Int -> ( ( MultiStatus, Int ), ( Row, Col ) ) +eatMultiCommentHelp src pos end row col openComments = + if pos >= end then + ( ( MultiEndless, pos ), ( row, col ) ) + + else + let + word : Char + word = + P.unsafeIndex src pos + in + if word == '\n' then + eatMultiCommentHelp src (pos + 1) end (row + 1) 1 openComments + + else if word == '\t' then + ( ( MultiTab, pos ), ( row, col ) ) + + else if word == '-' && P.isWord src (pos + 1) end '}' then + if openComments == 1 then + ( ( MultiGood, pos + 2 ), ( row, col + 2 ) ) + + else + eatMultiCommentHelp src (pos + 2) end row (col + 2) (openComments - 1) + + else if word == '{' && P.isWord src (pos + 1) end '-' then + eatMultiCommentHelp src (pos + 2) end row (col + 2) (openComments + 1) + + else + let + newPos : Int + newPos = + pos + P.getCharWidth word + in + eatMultiCommentHelp src newPos end row (col + 1) openComments + + + +-- DOCUMENTATION COMMENT + + +docComment : (Int -> Int -> x) -> (E.Space -> Int -> Int -> x) -> P.Parser x Src.Comment +docComment toExpectation toSpaceError = + P.Parser <| + \(P.State src pos end indent row col) -> + let + pos3 : Int + pos3 = + pos + 3 + in + if + (pos3 <= end) + && (P.unsafeIndex src pos == '{') + && (P.unsafeIndex src (pos + 1) == '-') + && (P.unsafeIndex src (pos + 2) == '|') + then + let + col3 : Col + col3 = + col + 3 + + ( ( status, newPos ), ( newRow, newCol ) ) = + eatMultiCommentHelp src pos3 end row col3 1 + in + case status of + MultiGood -> + let + off : Int + off = + pos3 + + len : Int + len = + newPos - pos3 - 2 + + snippet : P.Snippet + snippet = + P.Snippet + { fptr = src + , offset = off + , length = len + , offRow = row + , offCol = col3 + } + + comment : Src.Comment + comment = + Src.Comment snippet + + newState : P.State + newState = + P.State src newPos end indent newRow newCol + in + P.Cok comment newState + + MultiTab -> + P.Cerr newRow newCol (toSpaceError E.HasTab) + + MultiEndless -> + P.Cerr row col (toSpaceError E.EndlessMultiComment) + + else + P.Eerr row col toExpectation diff --git a/src/Compiler/Parse/String.elm b/src/Compiler/Parse/String.elm new file mode 100644 index 0000000000..00d2c29dbb --- /dev/null +++ b/src/Compiler/Parse/String.elm @@ -0,0 +1,426 @@ +module Compiler.Parse.String exposing + ( character + , string + ) + +import Compiler.Elm.String as ES +import Compiler.Parse.Number as Number +import Compiler.Parse.Primitives as P exposing (Col, Parser(..), Row) +import Compiler.Parse.SyntaxVersion exposing (SyntaxVersion) +import Compiler.Reporting.Error.Syntax as E + + + +-- CHARACTER + + +character : SyntaxVersion -> (Row -> Col -> x) -> (E.Char -> Row -> Col -> x) -> Parser x String +character syntaxVersion toExpectation toError = + Parser + (\(P.State src pos end indent row col) -> + if pos >= end || P.unsafeIndex src pos /= '\'' then + P.Eerr row col toExpectation + + else + case chompChar syntaxVersion src (pos + 1) end row (col + 1) 0 placeholder of + Good newPos newCol numChars mostRecent -> + if numChars /= 1 then + P.Cerr row col (toError (E.CharNotString (newCol - col))) + + else + let + newState : P.State + newState = + P.State src newPos end indent row newCol + + char : String + char = + ES.fromChunks src [ mostRecent ] + in + P.Cok char newState + + CharEndless newCol -> + P.Cerr row newCol (toError E.CharEndless) + + CharEscape r c escape -> + P.Cerr r c (toError (E.CharEscape escape)) + ) + + +type CharResult + = Good Int Col Int ES.Chunk + | CharEndless Col + | CharEscape Row Col E.Escape + + +chompChar : SyntaxVersion -> String -> Int -> Int -> Row -> Col -> Int -> ES.Chunk -> CharResult +chompChar syntaxVersion src pos end row col numChars mostRecent = + if pos >= end then + CharEndless col + + else + let + word : Char + word = + P.unsafeIndex src pos + in + if word == '\'' then + Good (pos + 1) (col + 1) numChars mostRecent + + else if word == '\n' then + CharEndless col + + else if word == '"' then + chompChar syntaxVersion src (pos + 1) end row (col + 1) (numChars + 1) doubleQuote + + else if word == '\\' then + case eatEscape syntaxVersion src (pos + 1) end row col of + EscapeNormal -> + chompChar syntaxVersion src (pos + 2) end row (col + 2) (numChars + 1) (ES.Slice pos 2) + + EscapeUnicode delta code -> + chompChar syntaxVersion src (pos + delta) end row (col + delta) (numChars + 1) (ES.CodePoint code) + + EscapeProblem r c badEscape -> + CharEscape r c badEscape + + EscapeEndOfFile -> + CharEndless col + + else + let + width : Int + width = + P.getCharWidth word + + newPos : Int + newPos = + pos + width + in + chompChar syntaxVersion src newPos end row (col + 1) (numChars + 1) (ES.Slice pos width) + + + +-- STRINGS + + +string : SyntaxVersion -> (Row -> Col -> x) -> (E.String_ -> Row -> Col -> x) -> Parser x ( String, Bool ) +string syntaxVersion toExpectation toError = + Parser + (\(P.State src pos end indent row col) -> + if isDoubleQuote src pos end then + let + pos1 : Int + pos1 = + pos + 1 + in + case + if isDoubleQuote src pos1 end then + let + pos2 : Int + pos2 = + pos + 2 + in + if isDoubleQuote src pos2 end then + let + pos3 : Int + pos3 = + pos + 3 + + col3 : Col + col3 = + col + 3 + in + multiString syntaxVersion src pos3 end row col3 pos3 row col [] + + else + SROk pos2 row (col + 2) "" False + + else + singleString syntaxVersion src pos1 end row (col + 1) pos1 [] + of + SROk newPos newRow newCol utf8 multiline -> + let + newState : P.State + newState = + P.State src newPos end indent newRow newCol + in + P.Cok ( utf8, multiline ) newState + + SRErr r c x -> + P.Cerr r c (toError x) + + else + P.Eerr row col toExpectation + ) + + +isDoubleQuote : String -> Int -> Int -> Bool +isDoubleQuote src pos end = + pos < end && P.unsafeIndex src pos == '"' + + +type StringResult + = SROk Int Row Col String Bool + | SRErr Row Col E.String_ + + +finalize : String -> Int -> Int -> List ES.Chunk -> String +finalize src start end revChunks = + ES.fromChunks src <| + List.reverse <| + if start == end then + revChunks + + else + -- String.fromList (List.map (P.unsafeIndex src) (List.range start (end - 1))) ++ revChunks + ES.Slice start (end - start) :: revChunks + + +addEscape : ES.Chunk -> Int -> Int -> List ES.Chunk -> List ES.Chunk +addEscape chunk start end revChunks = + if start == end then + chunk :: revChunks + + else + chunk :: ES.Slice start (end - start) :: revChunks + + + +-- SINGLE STRINGS + + +singleString : SyntaxVersion -> String -> Int -> Int -> Row -> Col -> Int -> List ES.Chunk -> StringResult +singleString syntaxVersion src pos end row col initialPos revChunks = + if pos >= end then + SRErr row col E.StringEndless_Single + + else + let + word : Char + word = + P.unsafeIndex src pos + in + if word == '"' then + SROk (pos + 1) + row + (col + 1) + (finalize src initialPos pos revChunks) + False + + else if word == '\n' then + SRErr row col E.StringEndless_Single + + else if word == '\'' then + let + newPos : Int + newPos = + pos + 1 + in + singleString syntaxVersion src newPos end row (col + 1) newPos <| + addEscape singleQuote initialPos pos revChunks + + else if word == '\\' then + case eatEscape syntaxVersion src (pos + 1) end row col of + EscapeNormal -> + singleString syntaxVersion src (pos + 2) end row (col + 2) initialPos revChunks + + EscapeUnicode delta code -> + let + newPos : Int + newPos = + pos + delta + in + singleString syntaxVersion src newPos end row (col + delta) newPos <| + addEscape (ES.CodePoint code) initialPos pos revChunks + + EscapeProblem r c x -> + SRErr r c (E.StringEscape x) + + EscapeEndOfFile -> + SRErr row (col + 1) E.StringEndless_Single + + else + let + newPos : Int + newPos = + pos + P.getCharWidth word + in + singleString syntaxVersion src newPos end row (col + 1) initialPos revChunks + + + +-- MULTI STRINGS + + +multiString : SyntaxVersion -> String -> Int -> Int -> Row -> Col -> Int -> Row -> Col -> List ES.Chunk -> StringResult +multiString syntaxVersion src pos end row col initialPos sr sc revChunks = + if pos >= end then + SRErr sr sc E.StringEndless_Multi + + else + let + word : Char + word = + P.unsafeIndex src pos + in + if word == '"' && isDoubleQuote src (pos + 1) end && isDoubleQuote src (pos + 2) end then + SROk (pos + 3) + row + (col + 3) + (finalize src initialPos pos revChunks) + True + + else if word == '\'' then + let + pos1 : Int + pos1 = + pos + 1 + in + multiString syntaxVersion src pos1 end row (col + 1) pos1 sr sc <| + addEscape singleQuote initialPos pos revChunks + + else if word == '\n' then + let + pos1 : Int + pos1 = + pos + 1 + in + multiString syntaxVersion src pos1 end (row + 1) 1 pos1 sr sc <| + addEscape newline initialPos pos revChunks + + else if word == '\u{000D}' then + let + pos1 : Int + pos1 = + pos + 1 + in + multiString syntaxVersion src pos1 end row col pos1 sr sc <| + addEscape carriageReturn initialPos pos revChunks + + else if word == '\\' then + case eatEscape syntaxVersion src (pos + 1) end row col of + EscapeNormal -> + multiString syntaxVersion src (pos + 2) end row (col + 2) initialPos sr sc revChunks + + EscapeUnicode delta code -> + let + newPos : Int + newPos = + pos + delta + in + multiString syntaxVersion src newPos end row (col + delta) newPos sr sc <| + addEscape (ES.CodePoint code) initialPos pos revChunks + + EscapeProblem r c x -> + SRErr r c (E.StringEscape x) + + EscapeEndOfFile -> + SRErr sr sc E.StringEndless_Multi + + else + let + newPos : Int + newPos = + pos + P.getCharWidth word + in + multiString syntaxVersion src newPos end row (col + 1) initialPos sr sc revChunks + + + +-- ESCAPE CHARACTERS + + +type Escape + = EscapeNormal + | EscapeUnicode Int Int + | EscapeEndOfFile + | EscapeProblem Row Col E.Escape + + +eatEscape : SyntaxVersion -> String -> Int -> Int -> Row -> Col -> Escape +eatEscape syntaxVersion src pos end row col = + if pos >= end then + EscapeEndOfFile + + else + case P.unsafeIndex src pos of + 'n' -> + EscapeNormal + + 'r' -> + EscapeNormal + + 't' -> + EscapeNormal + + '"' -> + EscapeNormal + + '\'' -> + EscapeNormal + + '\\' -> + EscapeNormal + + 'u' -> + eatUnicode syntaxVersion src (pos + 1) end row col + + _ -> + EscapeProblem row col E.EscapeUnknown + + +eatUnicode : SyntaxVersion -> String -> Int -> Int -> Row -> Col -> Escape +eatUnicode syntaxVersion src pos end row col = + if pos >= end || P.unsafeIndex src pos /= '{' then + EscapeProblem row col (E.BadUnicodeFormat 2) + + else + let + digitPos : Int + digitPos = + pos + 1 + + ( newPos, code ) = + Number.chompHex syntaxVersion src digitPos end + + numDigits : Int + numDigits = + newPos - digitPos + in + if newPos >= end || P.unsafeIndex src newPos /= '}' then + EscapeProblem row col (E.BadUnicodeFormat (2 + numDigits)) + + else if code < 0 || code > 0x0010FFFF then + EscapeProblem row col (E.BadUnicodeCode (3 + numDigits)) + + else if numDigits < 4 || numDigits > 6 then + EscapeProblem row col (E.BadUnicodeLength (3 + numDigits) numDigits code) + + else + EscapeUnicode (numDigits + 4) code + + +singleQuote : ES.Chunk +singleQuote = + ES.Escape '\'' + + +doubleQuote : ES.Chunk +doubleQuote = + ES.Escape '"' + + +newline : ES.Chunk +newline = + ES.Escape 'n' + + +carriageReturn : ES.Chunk +carriageReturn = + ES.Escape 'r' + + +placeholder : ES.Chunk +placeholder = + ES.CodePoint 0xFFFD diff --git a/src/Compiler/Parse/Symbol.elm b/src/Compiler/Parse/Symbol.elm new file mode 100644 index 0000000000..5bd76400cb --- /dev/null +++ b/src/Compiler/Parse/Symbol.elm @@ -0,0 +1,142 @@ +module Compiler.Parse.Symbol exposing + ( BadOperator(..) + , badOperatorDecoder + , badOperatorEncoder + , binopCharSet + , operator + ) + +import Compiler.Data.Name exposing (Name) +import Compiler.Parse.Primitives as P exposing (Col, Parser, Row) +import Data.Set as EverySet exposing (EverySet) +import Utils.Bytes.Decode as BD +import Utils.Bytes.Encode as BE + + + +-- OPERATOR + + +type BadOperator + = BadDot + | BadPipe + | BadArrow + | BadEquals + | BadHasType + + +operator : (Row -> Col -> x) -> (BadOperator -> Row -> Col -> x) -> Parser x Name +operator toExpectation toError = + P.Parser <| + \(P.State src pos end indent row col) -> + let + newPos : Int + newPos = + chompOps src pos end + in + if pos == newPos then + P.Eerr row col toExpectation + + else + case String.slice pos newPos src of + "." -> + P.Eerr row col (toError BadDot) + + "|" -> + P.Cerr row col (toError BadPipe) + + "->" -> + P.Cerr row col (toError BadArrow) + + "=" -> + P.Cerr row col (toError BadEquals) + + ":" -> + P.Cerr row col (toError BadHasType) + + op -> + let + newCol : Col + newCol = + col + (newPos - pos) + + newState : P.State + newState = + P.State src newPos end indent row newCol + in + P.Cok op newState + + +chompOps : String -> Int -> Int -> Int +chompOps src pos end = + if pos < end && isBinopCharHelp (P.unsafeIndex src pos) then + chompOps src (pos + 1) end + + else + pos + + +isBinopCharHelp : Char -> Bool +isBinopCharHelp char = + let + code : Int + code = + Char.toCode char + in + EverySet.member identity code binopCharSet + + +binopCharSet : EverySet Int Int +binopCharSet = + EverySet.fromList identity (List.map Char.toCode (String.toList "+-/*=.<>:&|^?%!")) + + + +-- ENCODERS and DECODERS + + +badOperatorEncoder : BadOperator -> BE.Encoder +badOperatorEncoder badOperator = + BE.unsignedInt8 + (case badOperator of + BadDot -> + 0 + + BadPipe -> + 1 + + BadArrow -> + 2 + + BadEquals -> + 3 + + BadHasType -> + 4 + ) + + +badOperatorDecoder : BD.Decoder BadOperator +badOperatorDecoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.succeed BadDot + + 1 -> + BD.succeed BadPipe + + 2 -> + BD.succeed BadArrow + + 3 -> + BD.succeed BadEquals + + 4 -> + BD.succeed BadHasType + + _ -> + BD.fail + ) diff --git a/src/Compiler/Parse/SyntaxVersion.elm b/src/Compiler/Parse/SyntaxVersion.elm new file mode 100644 index 0000000000..766e677a77 --- /dev/null +++ b/src/Compiler/Parse/SyntaxVersion.elm @@ -0,0 +1,69 @@ +module Compiler.Parse.SyntaxVersion exposing + ( SyntaxVersion(..) + , decoder + , encoder + , fileSyntaxVersion + ) + +{-| Compiler.Parse.SyntaxVersion +-} + +import Utils.Bytes.Decode as BD +import Utils.Bytes.Encode as BE + + +{-| The `SyntaxVersion` type is used to specify which syntax version to work +with. It provides options to differentiate between the "legacy" Elm syntax, +which the Guida language builds upon, and the new Guida-specific syntax. + +This type is useful when building parsers that need to distinguish between +the two syntactic styles and adapt behavior accordingly. + +-} +type SyntaxVersion + = Elm + | Guida + + +{-| Returns the syntax version based on a filepath. +-} +fileSyntaxVersion : String -> SyntaxVersion +fileSyntaxVersion path = + if String.endsWith ".elm" path then + Elm + + else + Guida + + + +-- ENCODERS and DECODERS + + +encoder : SyntaxVersion -> BE.Encoder +encoder syntaxVersion = + BE.unsignedInt8 + (case syntaxVersion of + Elm -> + 0 + + Guida -> + 1 + ) + + +decoder : BD.Decoder SyntaxVersion +decoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.succeed Elm + + 1 -> + BD.succeed Guida + + _ -> + BD.fail + ) diff --git a/src/Compiler/Parse/Type.elm b/src/Compiler/Parse/Type.elm new file mode 100644 index 0000000000..caead5bac3 --- /dev/null +++ b/src/Compiler/Parse/Type.elm @@ -0,0 +1,359 @@ +module Compiler.Parse.Type exposing + ( expression + , variant + ) + +import Compiler.AST.Source as Src +import Compiler.Data.Name exposing (Name) +import Compiler.Parse.Primitives as P +import Compiler.Parse.Space as Space +import Compiler.Parse.Variable as Var +import Compiler.Reporting.Annotation as A +import Compiler.Reporting.Error.Syntax as E + + + +-- TYPE TERMS + + +term : P.Parser E.Type Src.Type +term = + P.getPosition + |> P.bind + (\start -> + P.oneOf E.TStart + [ -- types with no arguments (Int, Float, etc.) + Var.foreignUpper E.TStart + |> P.bind + (\upper -> + P.getPosition + |> P.fmap + (\end -> + let + region : A.Region + region = + A.Region start end + in + A.At region <| + case upper of + Var.Unqualified name -> + Src.TType region name [] + + Var.Qualified home name -> + Src.TTypeQual region home name [] + ) + ) + , -- type variables + Var.lower E.TStart + |> P.bind + (\var -> + P.addEnd start (Src.TVar var) + ) + , -- tuples + P.inContext E.TTuple (P.word1 '(' E.TStart) <| + P.oneOf E.TTupleOpen + [ P.word1 ')' E.TTupleOpen + |> P.bind (\_ -> P.addEnd start Src.TUnit) + , Space.chompAndCheckIndent E.TTupleSpace E.TTupleIndentType1 + |> P.bind + (\trailingComments -> + P.specialize E.TTupleType (expression trailingComments) + |> P.bind + (\( tipe, end ) -> + Space.checkIndent end E.TTupleIndentEnd + |> P.bind (\_ -> chompTupleEnd start tipe []) + ) + ) + ] + , -- records + P.inContext E.TRecord (P.word1 '{' E.TStart) <| + (Space.chompAndCheckIndent E.TRecordSpace E.TRecordIndentOpen + |> P.bind + (\initialComments -> + P.oneOf E.TRecordOpen + [ P.word1 '}' E.TRecordEnd + |> P.bind (\_ -> P.addEnd start (Src.TRecord [] Nothing initialComments)) + , P.addLocation (Var.lower E.TRecordField) + |> P.bind + (\name -> + Space.chompAndCheckIndent E.TRecordSpace E.TRecordIndentColon + |> P.bind + (\postNameComments -> + P.oneOf E.TRecordColon + [ P.word1 '|' E.TRecordColon + |> P.bind + (\_ -> + Space.chompAndCheckIndent E.TRecordSpace E.TRecordIndentField + |> P.bind + (\preFieldComments -> + chompField + |> P.bind + (\( postFieldComments, field ) -> + chompRecordEnd postFieldComments [ ( ( [], preFieldComments ), field ) ] + |> P.bind (\( trailingComments, fields ) -> P.addEnd start (Src.TRecord fields (Just ( ( initialComments, postNameComments ), name )) trailingComments)) + ) + ) + ) + , P.word1 ':' E.TRecordColon + |> P.bind + (\_ -> + Space.chompAndCheckIndent E.TRecordSpace E.TRecordIndentType + |> P.bind + (\preTypeComments -> + P.specialize E.TRecordType (expression []) + |> P.bind + (\( ( ( _, postExpressionComments, _ ), tipe ), end ) -> + Space.checkIndent end E.TRecordIndentEnd + |> P.bind + (\_ -> + chompRecordEnd postExpressionComments [ ( ( [], initialComments ), ( ( postNameComments, name ), ( preTypeComments, tipe ) ) ) ] + |> P.bind (\( trailingComments, fields ) -> P.addEnd start (Src.TRecord fields Nothing trailingComments)) + ) + ) + ) + ) + ] + ) + ) + ] + ) + ) + ] + ) + + + +-- TYPE EXPRESSIONS + + +expression : Src.FComments -> Space.Parser E.Type (Src.C2Eol Src.Type) +expression trailingComments = + P.getPosition + |> P.bind + (\start -> + P.oneOf E.TStart + [ app start + , term + |> P.bind + (\eterm -> + P.getPosition + |> P.bind + (\end -> + Space.chomp E.TSpace + |> P.fmap (\postTermComments -> ( ( postTermComments, eterm ), end )) + ) + ) + ] + |> P.bind + (\( ( postTipe1comments, tipe1 ), end1 ) -> + P.oneOfWithFallback + [ -- should never trigger + Space.checkIndent end1 E.TIndentStart + |> P.bind + (\_ -> + -- could just be another type instead + P.word2 '-' '>' E.TStart + |> P.bind + (\_ -> + Space.chompAndCheckIndent E.TSpace E.TIndentStart + |> P.bind + (\postArrowComments -> + expression postArrowComments + |> P.fmap + (\( ( ( preTipe2Comments, postTipe2Comments, tipe2Eol ), tipe2 ), end2 ) -> + let + tipe : Src.Type + tipe = + A.at start end2 (Src.TLambda ( Nothing, tipe1 ) ( ( postTipe1comments, preTipe2Comments, tipe2Eol ), tipe2 )) + in + ( ( ( trailingComments, postTipe2Comments, Nothing ), tipe ), end2 ) + ) + ) + ) + ) + ] + ( ( ( trailingComments, postTipe1comments, Nothing ), tipe1 ), end1 ) + ) + ) + + + +-- TYPE CONSTRUCTORS + + +app : A.Position -> Space.Parser E.Type (Src.C1 Src.Type) +app start = + Var.foreignUpper E.TStart + |> P.bind + (\upper -> + P.getPosition + |> P.bind + (\upperEnd -> + Space.chomp E.TSpace + |> P.bind + (\postUpperComments -> + chompArgs postUpperComments [] upperEnd + |> P.fmap + (\( ( comments, args ), end ) -> + let + region : A.Region + region = + A.Region start upperEnd + + tipe : Src.Type_ + tipe = + case upper of + Var.Unqualified name -> + Src.TType region name args + + Var.Qualified home name -> + Src.TTypeQual region home name args + in + ( ( comments, A.at start end tipe ), end ) + ) + ) + ) + ) + + +chompArgs : Src.FComments -> List (Src.C1 Src.Type) -> A.Position -> Space.Parser E.Type (Src.C1 (List (Src.C1 Src.Type))) +chompArgs preComments args end = + P.oneOfWithFallback + [ Space.checkIndent end E.TIndentStart + |> P.bind + (\_ -> + term + |> P.bind + (\arg -> + P.getPosition + |> P.bind + (\newEnd -> + Space.chomp E.TSpace + |> P.bind + (\comments -> + chompArgs comments (( preComments, arg ) :: args) newEnd + ) + ) + ) + ) + ] + ( ( preComments, List.reverse args ), end ) + + + +-- TUPLES + + +chompTupleEnd : A.Position -> Src.C2Eol Src.Type -> List (Src.C2Eol Src.Type) -> P.Parser E.TTuple Src.Type +chompTupleEnd start ( firstTimeComments, firstType ) revTypes = + P.oneOf E.TTupleEnd + [ P.word1 ',' E.TTupleEnd + |> P.bind + (\_ -> + Space.chompAndCheckIndent E.TTupleSpace E.TTupleIndentTypeN + |> P.bind + (\preExpressionComments -> + P.specialize E.TTupleType (expression preExpressionComments) + |> P.bind + (\( tipe, end ) -> + Space.checkIndent end E.TTupleIndentEnd + |> P.bind + (\_ -> + chompTupleEnd start ( firstTimeComments, firstType ) (tipe :: revTypes) + ) + ) + ) + ) + , P.word1 ')' E.TTupleEnd + |> P.bind (\_ -> P.getPosition) + |> P.bind + (\end -> + case List.reverse revTypes of + [] -> + case firstTimeComments of + ( [], [], _ ) -> + P.pure firstType + + ( startParensComments, endParensComments, _ ) -> + P.pure (A.at start end (Src.TParens ( ( startParensComments, endParensComments ), firstType ))) + + secondType :: otherTypes -> + P.addEnd start (Src.TTuple ( firstTimeComments, firstType ) secondType otherTypes) + ) + ] + + + +-- RECORD + + +type alias Field = + ( Src.C1 (A.Located Name), Src.C1 Src.Type ) + + +chompRecordEnd : Src.FComments -> List (Src.C2 Field) -> P.Parser E.TRecord (Src.C1 (List (Src.C2 Field))) +chompRecordEnd comments fields = + P.oneOf E.TRecordEnd + [ P.word1 ',' E.TRecordEnd + |> P.bind + (\_ -> + Space.chompAndCheckIndent E.TRecordSpace E.TRecordIndentField + |> P.bind + (\preNameComments -> + chompField + |> P.bind + (\( postFieldComments, field ) -> + chompRecordEnd postFieldComments (( ( comments, preNameComments ), field ) :: fields) + ) + ) + ) + , P.word1 '}' E.TRecordEnd + |> P.fmap (\_ -> ( comments, List.reverse fields )) + ] + + +chompField : P.Parser E.TRecord (Src.C1 Field) +chompField = + P.addLocation (Var.lower E.TRecordField) + |> P.bind + (\name -> + Space.chompAndCheckIndent E.TRecordSpace E.TRecordIndentColon + |> P.bind + (\postNameComments -> + P.word1 ':' E.TRecordColon + |> P.bind + (\_ -> + Space.chompAndCheckIndent E.TRecordSpace E.TRecordIndentType + |> P.bind + (\preTypeComments -> + P.specialize E.TRecordType (expression []) + |> P.bind + (\( ( ( _, x1, _ ), tipe ), end ) -> + Space.checkIndent end E.TRecordIndentEnd + |> P.fmap (\_ -> ( x1, ( ( postNameComments, name ), ( preTypeComments, tipe ) ) )) + ) + ) + ) + ) + ) + + + +-- VARIANT + + +variant : Src.FComments -> Space.Parser E.CustomType (Src.C2Eol ( A.Located Name, List (Src.C1 Src.Type) )) +variant trailingComments = + P.addLocation (Var.upper E.CT_Variant) + |> P.bind + (\((A.At (A.Region _ nameEnd) _) as name) -> + Space.chomp E.CT_Space + |> P.bind + (\preArgComments -> + P.specialize E.CT_VariantArg (chompArgs preArgComments [] nameEnd) + |> P.fmap + (\( ( postArgsComments, args ), end ) -> + ( ( ( trailingComments, postArgsComments, Nothing ), ( name, args ) ), end ) + ) + ) + ) diff --git a/src/Compiler/Parse/Variable.elm b/src/Compiler/Parse/Variable.elm new file mode 100644 index 0000000000..6116cd1b46 --- /dev/null +++ b/src/Compiler/Parse/Variable.elm @@ -0,0 +1,607 @@ +module Compiler.Parse.Variable exposing + ( Upper(..) + , chompInnerChars + , chompLower + , chompUpper + , foreignAlpha + , foreignUpper + , getInnerWidth + , getInnerWidthHelp + , getUpperWidth + , isDot + , isReservedWord + , lower + , moduleName + , upper + ) + +import Bitwise +import Compiler.AST.Source as Src +import Compiler.Data.Name as Name exposing (Name) +import Compiler.Parse.Primitives as P exposing (Col, Row) +import Data.Set as EverySet exposing (EverySet) + + + +-- LOCAL UPPER + + +upper : (Row -> Col -> x) -> P.Parser x Name +upper toError = + P.Parser <| + \(P.State src pos end indent row col) -> + let + ( newPos, newCol ) = + chompUpper src pos end col + in + if newPos == pos then + P.Eerr row col toError + + else + let + name : Name + name = + Name.fromPtr src pos newPos + in + P.Cok name (P.State src newPos end indent row newCol) + + + +-- LOCAL LOWER + + +lower : (Row -> Col -> x) -> P.Parser x Name +lower toError = + P.Parser <| + \(P.State src pos end indent row col) -> + let + ( newPos, newCol ) = + chompLower src pos end col + in + if newPos == pos then + P.Eerr row col toError + + else + let + name : Name + name = + Name.fromPtr src pos newPos + in + if isReservedWord name then + P.Eerr row col toError + + else + let + newState : P.State + newState = + P.State src newPos end indent row newCol + in + P.Cok name newState + + +isReservedWord : Name.Name -> Bool +isReservedWord name = + EverySet.member identity name reservedWords + + +reservedWords : EverySet String Name +reservedWords = + EverySet.fromList identity + [ "if" + , "then" + , "else" + , "case" + , "of" + , "let" + , "in" + , "type" + , "module" + , "where" + , "import" + , "exposing" + , "as" + , "port" + ] + + + +-- MODULE NAME + + +moduleName : (Row -> Col -> x) -> P.Parser x Name +moduleName toError = + P.Parser <| + \(P.State src pos end indent row col) -> + let + ( pos1, col1 ) = + chompUpper src pos end col + in + if pos == pos1 then + P.Eerr row col toError + + else + let + ( status, newPos, newCol ) = + moduleNameHelp src pos1 end col1 + in + case status of + Good -> + let + name : Name + name = + Name.fromPtr src pos newPos + + newState : P.State + newState = + P.State src newPos end indent row newCol + in + P.Cok name newState + + Bad -> + P.Cerr row newCol toError + + +type ModuleNameStatus + = Good + | Bad + + +moduleNameHelp : String -> Int -> Int -> Col -> ( ModuleNameStatus, Int, Col ) +moduleNameHelp src pos end col = + if isDot src pos end then + let + pos1 : Int + pos1 = + pos + 1 + + ( newPos, newCol ) = + chompUpper src pos1 end (col + 1) + in + if pos1 == newPos then + ( Bad, newPos, newCol ) + + else + moduleNameHelp src newPos end newCol + + else + ( Good, pos, col ) + + + +-- FOREIGN UPPER + + +type Upper + = Unqualified Name + | Qualified Name Name + + +foreignUpper : (Row -> Col -> x) -> P.Parser x Upper +foreignUpper toError = + P.Parser <| + \(P.State src pos end indent row col) -> + let + ( upperStart, upperEnd, newCol ) = + foreignUpperHelp src pos end col + in + if upperStart == upperEnd then + P.Eerr row newCol toError + + else + let + newState : P.State + newState = + P.State src upperEnd end indent row newCol + + name : Name + name = + Name.fromPtr src upperStart upperEnd + + upperName : Upper + upperName = + if upperStart == pos then + Unqualified name + + else + let + home : Name + home = + Name.fromPtr src pos (upperStart + -1) + in + Qualified home name + in + P.Cok upperName newState + + +foreignUpperHelp : String -> Int -> Int -> Col -> ( Int, Int, Col ) +foreignUpperHelp src pos end col = + let + ( newPos, newCol ) = + chompUpper src pos end col + in + if pos == newPos then + ( pos, pos, col ) + + else if isDot src newPos end then + foreignUpperHelp src (newPos + 1) end (newCol + 1) + + else + ( pos, newPos, newCol ) + + + +-- FOREIGN ALPHA + + +foreignAlpha : (Row -> Col -> x) -> P.Parser x Src.Expr_ +foreignAlpha toError = + P.Parser <| + \(P.State src pos end indent row col) -> + let + ( ( alphaStart, alphaEnd ), ( newCol, varType ) ) = + foreignAlphaHelp src pos end col + in + if alphaStart == alphaEnd then + P.Eerr row newCol toError + + else + let + name : Name + name = + Name.fromPtr src alphaStart alphaEnd + + newState : P.State + newState = + P.State src alphaEnd end indent row newCol + in + if alphaStart == pos then + if isReservedWord name then + P.Eerr row col toError + + else + P.Cok (Src.Var varType name) newState + + else + let + home : Name + home = + Name.fromPtr src pos (alphaStart + -1) + in + P.Cok (Src.VarQual varType home name) newState + + +foreignAlphaHelp : String -> Int -> Int -> Col -> ( ( Int, Int ), ( Col, Src.VarType ) ) +foreignAlphaHelp src pos end col = + let + ( lowerPos, lowerCol ) = + chompLower src pos end col + in + if pos < lowerPos then + ( ( pos, lowerPos ), ( lowerCol, Src.LowVar ) ) + + else + let + ( upperPos, upperCol ) = + chompUpper src pos end col + in + if pos == upperPos then + ( ( pos, pos ), ( col, Src.CapVar ) ) + + else if isDot src upperPos end then + foreignAlphaHelp src (upperPos + 1) end (upperCol + 1) + + else + ( ( pos, upperPos ), ( upperCol, Src.CapVar ) ) + + + +---- CHAR CHOMPERS ---- +-- DOTS + + +isDot : String -> Int -> Int -> Bool +isDot src pos end = + pos < end && P.unsafeIndex src pos == '.' + + + +-- UPPER CHARS + + +chompUpper : String -> Int -> Int -> Col -> ( Int, Col ) +chompUpper src pos end col = + let + width : Int + width = + getUpperWidth src pos end + in + if width == 0 then + ( pos, col ) + + else + chompInnerChars src (pos + width) end (col + 1) + + +getUpperWidth : String -> Int -> Int -> Int +getUpperWidth src pos end = + if pos < end then + getUpperWidthHelp src pos end (P.unsafeIndex src pos) + + else + 0 + + +getUpperWidthHelp : String -> Int -> Int -> Char -> Int +getUpperWidthHelp src pos _ word = + let + code : Int + code = + Char.toCode word + in + if code >= 0x41 {- A -} && code <= 0x5A {- Z -} then + 1 + + else if code < 0xC0 then + 0 + + else if code < 0xE0 then + if Char.isUpper (chr2 src pos word) then + 2 + + else + 0 + + else if code < 0xF0 then + if Char.isUpper (chr3 src pos word) then + 3 + + else + 0 + + else if code < 0xF8 then + if Char.isUpper (chr4 src pos word) then + 4 + + else + 0 + + else + 0 + + + +-- LOWER CHARS + + +chompLower : String -> Int -> Int -> Col -> ( Int, Col ) +chompLower src pos end col = + let + width : Int + width = + getLowerWidth src pos end + in + if width == 0 then + ( pos, col ) + + else + chompInnerChars src (pos + width) end (col + 1) + + +getLowerWidth : String -> Int -> Int -> Int +getLowerWidth src pos end = + if pos < end then + getLowerWidthHelp src pos end (P.unsafeIndex src pos) + + else + 0 + + +getLowerWidthHelp : String -> Int -> Int -> Char -> Int +getLowerWidthHelp src pos _ word = + let + code : Int + code = + Char.toCode word + in + if code >= 0x61 {- a -} && code <= 0x7A {- z -} then + 1 + + else if code < 0xC0 then + 0 + + else if code < 0xE0 then + if Char.isLower (chr2 src pos word) then + 2 + + else + 0 + + else if code < 0xF0 then + if Char.isLower (chr3 src pos word) then + 3 + + else + 0 + + else if code < 0xF8 then + if Char.isLower (chr4 src pos word) then + 4 + + else + 0 + + else + 0 + + + +-- INNER CHARS + + +chompInnerChars : String -> Int -> Int -> Col -> ( Int, Col ) +chompInnerChars src pos end col = + let + width : Int + width = + getInnerWidth src pos end + in + if width == 0 then + ( pos, col ) + + else + chompInnerChars src (pos + width) end (col + 1) + + +getInnerWidth : String -> Int -> Int -> Int +getInnerWidth src pos end = + if pos < end then + getInnerWidthHelp src pos end (P.unsafeIndex src pos) + + else + 0 + + +getInnerWidthHelp : String -> Int -> Int -> Char -> Int +getInnerWidthHelp src pos _ word = + let + code : Int + code = + Char.toCode word + in + if code >= 0x61 {- a -} && code <= 0x7A {- z -} then + 1 + + else if code >= 0x41 {- A -} && code <= 0x5A {- Z -} then + 1 + + else if code >= 0x30 {- 0 -} && code <= 0x39 {- 9 -} then + 1 + + else if code == 0x5F {- _ -} then + 1 + + else if code < 0xC0 then + 0 + + else if code < 0xE0 then + if Char.isAlpha (chr2 src pos word) then + 2 + + else + 0 + + else if code < 0xF0 then + if Char.isAlpha (chr3 src pos word) then + 3 + + else + 0 + + else if code < 0xF8 then + if Char.isAlpha (chr4 src pos word) then + 4 + + else + 0 + + else + 0 + + + +-- EXTRACT CHARACTERS + + +chr2 : String -> Int -> Char -> Char +chr2 src pos firstWord = + let + i1 : Int + i1 = + unpack firstWord + + i2 : Int + i2 = + unpack (P.unsafeIndex src (pos + 1)) + + c1 : Int + c1 = + Bitwise.shiftLeftBy 6 (i1 - 0xC0) + + c2 : Int + c2 = + i2 - 0x80 + in + Char.fromCode (c1 + c2) + + +chr3 : String -> Int -> Char -> Char +chr3 src pos firstWord = + let + i1 : Int + i1 = + unpack firstWord + + i2 : Int + i2 = + unpack (P.unsafeIndex src (pos + 1)) + + i3 : Int + i3 = + unpack (P.unsafeIndex src (pos + 2)) + + c1 : Int + c1 = + Bitwise.shiftLeftBy 12 (i1 - 0xE0) + + c2 : Int + c2 = + Bitwise.shiftLeftBy 6 (i2 - 0x80) + + c3 : Int + c3 = + i3 - 0x80 + in + Char.fromCode (c1 + c2 + c3) + + +chr4 : String -> Int -> Char -> Char +chr4 src pos firstWord = + let + i1 : Int + i1 = + unpack firstWord + + i2 : Int + i2 = + unpack (P.unsafeIndex src (pos + 1)) + + i3 : Int + i3 = + unpack (P.unsafeIndex src (pos + 2)) + + i4 : Int + i4 = + unpack (P.unsafeIndex src (pos + 3)) + + c1 : Int + c1 = + Bitwise.shiftLeftBy 18 (i1 - 0xF0) + + c2 : Int + c2 = + Bitwise.shiftLeftBy 12 (i2 - 0x80) + + c3 : Int + c3 = + Bitwise.shiftLeftBy 6 (i3 - 0x80) + + c4 : Int + c4 = + i4 - 0x80 + in + Char.fromCode (c1 + c2 + c3 + c4) + + +unpack : Char -> Int +unpack = + Char.toCode diff --git a/src/Compiler/Reporting/Annotation.elm b/src/Compiler/Reporting/Annotation.elm new file mode 100644 index 0000000000..abd2ac7536 --- /dev/null +++ b/src/Compiler/Reporting/Annotation.elm @@ -0,0 +1,146 @@ +module Compiler.Reporting.Annotation exposing + ( Located(..) + , Position(..) + , Region(..) + , at + , compareLocated + , isMultiline + , locatedDecoder + , locatedEncoder + , merge + , mergeRegions + , one + , regionDecoder + , regionEncoder + , toRegion + , toValue + , traverse + , zero + ) + +import System.TypeCheck.IO as IO exposing (IO) +import Utils.Bytes.Decode as BD +import Utils.Bytes.Encode as BE + + + +-- LOCATED + + +type Located a + = At Region a -- PERF see if unpacking region is helpful + + +compareLocated : Located comparable -> Located comparable -> Order +compareLocated (At _ a) (At _ b) = + compare a b + + +traverse : (a -> IO b) -> Located a -> IO (Located b) +traverse func (At region value) = + IO.fmap (At region) (func value) + + +toValue : Located a -> a +toValue (At _ value) = + value + + +merge : Located a -> Located b -> c -> Located c +merge (At r1 _) (At r2 _) value = + At (mergeRegions r1 r2) value + + + +-- POSITION + + +type Position + = Position Int Int + + +at : Position -> Position -> a -> Located a +at start end a = + At (Region start end) a + + + +-- REGION + + +type Region + = Region Position Position + + +toRegion : Located a -> Region +toRegion (At region _) = + region + + +mergeRegions : Region -> Region -> Region +mergeRegions (Region start _) (Region _ end) = + Region start end + + +zero : Region +zero = + Region (Position 0 0) (Position 0 0) + + +one : Region +one = + Region (Position 1 1) (Position 1 1) + + +isMultiline : Region -> Bool +isMultiline (Region (Position startRow _) (Position endRow _)) = + startRow /= endRow + + + +-- ENCODERS and DECODERS + + +regionEncoder : Region -> BE.Encoder +regionEncoder (Region start end) = + BE.sequence + [ positionEncoder start + , positionEncoder end + ] + + +regionDecoder : BD.Decoder Region +regionDecoder = + BD.map2 Region + positionDecoder + positionDecoder + + +positionEncoder : Position -> BE.Encoder +positionEncoder (Position start end) = + BE.sequence + [ BE.int start + , BE.int end + ] + + +positionDecoder : BD.Decoder Position +positionDecoder = + BD.map2 Position + BD.int + BD.int + + +locatedEncoder : (a -> BE.Encoder) -> Located a -> BE.Encoder +locatedEncoder encoder (At region value) = + BE.sequence + [ regionEncoder region + , encoder value + ] + + +locatedDecoder : BD.Decoder a -> BD.Decoder (Located a) +locatedDecoder decoder = + BD.map2 At + regionDecoder + (BD.lazy (\_ -> decoder)) diff --git a/src/Compiler/Reporting/Doc.elm b/src/Compiler/Reporting/Doc.elm new file mode 100644 index 0000000000..4020c99409 --- /dev/null +++ b/src/Compiler/Reporting/Doc.elm @@ -0,0 +1,672 @@ +module Compiler.Reporting.Doc exposing + ( Doc + , plus, append, a + , align, cat, empty, fill, fillSep, hang + , hcat, hsep, indent, sep, vcat + , Color(..) + , red, cyan, green, blue, black, yellow + , dullred, dullcyan, dullyellow + , fromChars, fromName, fromVersion, fromPackage, fromInt + , toAnsi, toString, toLine + , encode + , stack, reflow, commaSep + , toSimpleNote, toFancyNote, toSimpleHint, toFancyHint + , link, fancyLink, reflowLink, makeLink, makeNakedLink + , args, moreArgs, ordinal, intToOrdinal, cycle + ) + +{-| + +@docs Doc +@docs plus, append, a +@docs align, cat, empty, fill, fillSep, hang +@docs hcat, hsep, indent, sep, vcat +@docs Color +@docs red, cyan, green, blue, black, yellow +@docs dullred, dullcyan, dullyellow +@docs fromChars, fromName, fromVersion, fromPackage, fromInt +@docs toAnsi, toString, toLine +@docs encode +@docs stack, reflow, commaSep +@docs toSimpleNote, toFancyNote, toSimpleHint, toFancyHint +@docs link, fancyLink, reflowLink, makeLink, makeNakedLink +@docs args, moreArgs, ordinal, intToOrdinal, cycle + +-} + +import Compiler.Data.Index as Index +import Compiler.Data.Name exposing (Name) +import Compiler.Elm.Package as Pkg +import Compiler.Elm.Version as V +import Compiler.Json.Encode as E +import Maybe.Extra as Maybe +import Prelude +import System.Console.Ansi as Ansi +import System.IO exposing (Handle) +import Task exposing (Task) +import Text.PrettyPrint.ANSI.Leijen as P + + + +-- FROM + + +fromChars : String -> Doc +fromChars = + P.text + + +fromName : Name -> Doc +fromName = + P.text + + +fromVersion : V.Version -> Doc +fromVersion vsn = + P.text (V.toChars vsn) + + +fromPackage : Pkg.Name -> Doc +fromPackage pkg = + P.text (Pkg.toChars pkg) + + +fromInt : Int -> Doc +fromInt n = + P.text (String.fromInt n) + + + +-- TO STRING + + +toAnsi : Handle -> Doc -> Task Never () +toAnsi handle doc = + P.displayIO handle (P.renderPretty 1 80 doc) + + +toString : Doc -> String +toString doc = + P.displayS (P.renderPretty 1 80 (P.plain doc)) "" + + +toLine : Doc -> String +toLine doc = + let + maxBound : number + maxBound = + 2147483647 + in + P.displayS (P.renderPretty 1 (maxBound // 2) (P.plain doc)) "" + + + +-- FORMATTING + + +stack : List Doc -> Doc +stack docs = + P.vcat (List.intersperse (P.text "") docs) + + +reflow : String -> Doc +reflow paragraph = + P.fillSep (List.map P.text (String.words paragraph)) + + +commaSep : Doc -> (Doc -> Doc) -> List Doc -> List Doc +commaSep conjunction addStyle names = + case names of + [ name ] -> + [ addStyle name ] + + [ name1, name2 ] -> + [ addStyle name1, conjunction, addStyle name2 ] + + _ -> + List.map (\name -> P.append (addStyle name) (P.text ",")) (Prelude.init names) + ++ [ conjunction + , addStyle (Prelude.last names) + ] + + + +-- NOTES + + +toSimpleNote : String -> Doc +toSimpleNote message = + toFancyNote (List.map P.text (String.words message)) + + +toFancyNote : List Doc -> Doc +toFancyNote chunks = + P.fillSep (P.append (P.underline (P.text "Note")) (P.text ":") :: chunks) + + + +-- HINTS + + +toSimpleHint : String -> Doc +toSimpleHint message = + toFancyHint (List.map P.text (String.words message)) + + +toFancyHint : List Doc -> Doc +toFancyHint chunks = + P.fillSep (P.append (P.underline (P.text "Hint")) (P.text ":") :: chunks) + + + +-- LINKS + + +link : String -> String -> String -> String -> Doc +link word before fileName after = + P.fillSep <| + P.append (P.underline (P.text word)) (P.text ":") + :: List.map P.text (String.words before) + ++ P.text (makeLink fileName) + :: List.map P.text (String.words after) + + +fancyLink : String -> List Doc -> String -> List Doc -> Doc +fancyLink word before fileName after = + P.fillSep <| + P.append (P.underline (P.text word)) (P.text ":") + :: before + ++ P.text (makeLink fileName) + :: after + + +makeLink : String -> String +makeLink fileName = + "<" ++ makeNakedLink fileName ++ ">" + + +makeNakedLink : String -> String +makeNakedLink fileName = + "https://elm-lang.org/" ++ V.toChars V.elmCompiler ++ "/" ++ fileName + + +reflowLink : String -> String -> String -> Doc +reflowLink before fileName after = + P.fillSep <| + List.map P.text (String.words before) + ++ P.text (makeLink fileName) + :: List.map P.text (String.words after) + + + +-- HELPERS + + +args : Int -> String +args n = + String.fromInt n + ++ (if n == 1 then + " argument" + + else + " arguments" + ) + + +moreArgs : Int -> String +moreArgs n = + String.fromInt n + ++ " more" + ++ (if n == 1 then + " argument" + + else + " arguments" + ) + + +ordinal : Index.ZeroBased -> String +ordinal index = + intToOrdinal (Index.toHuman index) + + +intToOrdinal : Int -> String +intToOrdinal number = + let + remainder100 : Int + remainder100 = + modBy 100 number + + ending : String + ending = + if List.member remainder100 [ 11, 12, 13 ] then + "th" + + else + let + remainder10 : Int + remainder10 = + modBy 10 number + in + if remainder10 == 1 then + "st" + + else if remainder10 == 2 then + "nd" + + else if remainder10 == 3 then + "rd" + + else + "th" + in + String.fromInt number ++ ending + + +cycle : Int -> Name -> List Name -> Doc +cycle indent_ name names = + let + toLn : Name -> P.Doc + toLn n = + P.append cycleLn (P.dullyellow (fromName n)) + in + P.indent indent_ <| + P.vcat <| + cycleTop + :: List.intersperse cycleMid (toLn name :: List.map toLn names) + ++ [ cycleEnd ] + + +cycleTop : Doc +cycleTop = + if isWindows then + P.text "+-----+" + + else + P.text "┌─────┐" + + +cycleLn : Doc +cycleLn = + if isWindows then + P.text "| " + + else + P.text "│ " + + +cycleMid : Doc +cycleMid = + if isWindows then + P.text "| |" + + else + P.text "│ ↓" + + +cycleEnd : Doc +cycleEnd = + if isWindows then + P.text "+-<---+" + + else + P.text "└─────┘" + + +isWindows : Bool +isWindows = + -- Info.os == "mingw32" + False + + + +-- JSON + + +encode : Doc -> E.Value +encode doc = + E.array (toJsonHelp noStyle [] (P.renderPretty 1 80 doc)) + + +type Style + = Style Bool Bool (Maybe Color) + + +noStyle : Style +noStyle = + Style False False Nothing + + +type Color + = Red + | RED + | Magenta + | MAGENTA + | Yellow + | YELLOW + | Green + | GREEN + | Cyan + | CYAN + | Blue + | BLUE + | Black + | BLACK + | White + | WHITE + + +toJsonHelp : Style -> List String -> P.SimpleDoc -> List E.Value +toJsonHelp style revChunks simpleDoc = + case simpleDoc of + P.SEmpty -> + [ encodeChunks style revChunks ] + + P.SText string rest -> + toJsonHelp style (string :: revChunks) rest + + P.SLine indent_ rest -> + toJsonHelp style (String.repeat indent_ " " :: "\n" :: revChunks) rest + + P.SSGR sgrs rest -> + encodeChunks style revChunks :: toJsonHelp (sgrToStyle sgrs style) [] rest + + +sgrToStyle : List Ansi.SGR -> Style -> Style +sgrToStyle sgrs ((Style bold underline color) as style) = + case sgrs of + [] -> + style + + sgr :: rest -> + sgrToStyle rest <| + case sgr of + Ansi.Reset -> + noStyle + + Ansi.SetConsoleIntensity i -> + Style (isBold i) underline color + + Ansi.SetItalicized _ -> + style + + Ansi.SetUnderlining u -> + Style bold (isUnderline u) color + + Ansi.SetBlinkSpeed _ -> + style + + Ansi.SetVisible _ -> + style + + Ansi.SetSwapForegroundBackground _ -> + style + + Ansi.SetColor l i c -> + Style bold underline (toColor l i c) + + +isBold : Ansi.ConsoleIntensity -> Bool +isBold intensity = + case intensity of + Ansi.BoldIntensity -> + True + + Ansi.FaintIntensity -> + False + + Ansi.NormalIntensity -> + False + + +isUnderline : Ansi.Underlining -> Bool +isUnderline underlining = + case underlining of + Ansi.SingleUnderline -> + True + + Ansi.DoubleUnderline -> + False + + Ansi.NoUnderline -> + False + + +toColor : Ansi.ConsoleLayer -> Ansi.ColorIntensity -> Ansi.Color -> Maybe Color +toColor layer intensity color = + case layer of + Ansi.Background -> + Nothing + + Ansi.Foreground -> + let + pick : b -> b -> b + pick dull vivid = + case intensity of + Ansi.Dull -> + dull + + Ansi.Vivid -> + vivid + in + Just <| + case color of + Ansi.Red -> + pick Red RED + + Ansi.Magenta -> + pick Magenta MAGENTA + + Ansi.Yellow -> + pick Yellow YELLOW + + Ansi.Green -> + pick Green GREEN + + Ansi.Cyan -> + pick Cyan CYAN + + Ansi.Blue -> + pick Blue BLUE + + Ansi.White -> + pick White WHITE + + Ansi.Black -> + pick Black BLACK + + +encodeChunks : Style -> List String -> E.Value +encodeChunks (Style bold underline color) revChunks = + let + chars : String + chars = + String.concat (List.reverse revChunks) + in + case ( color, not bold && not underline ) of + ( Nothing, True ) -> + E.chars chars + + _ -> + E.object + [ ( "bold", E.bool bold ) + , ( "underline", E.bool underline ) + , ( "color", Maybe.unwrap E.null encodeColor color ) + , ( "string", E.chars chars ) + ] + + +encodeColor : Color -> E.Value +encodeColor color = + E.string <| + case color of + Red -> + "red" + + RED -> + "RED" + + Magenta -> + "magenta" + + MAGENTA -> + "MAGENTA" + + Yellow -> + "yellow" + + YELLOW -> + "YELLOW" + + Green -> + "green" + + GREEN -> + "GREEN" + + Cyan -> + "cyan" + + CYAN -> + "CYAN" + + Blue -> + "blue" + + BLUE -> + "BLUE" + + Black -> + "black" + + BLACK -> + "BLACK" + + White -> + "white" + + WHITE -> + "WHITE" + + + +-- DOC + + +type alias Doc = + P.Doc + + +a : Doc -> Doc -> Doc +a = + P.a + + +plus : Doc -> Doc -> Doc +plus = + P.plus + + +append : Doc -> Doc -> Doc +append = + P.append + + +align : Doc -> Doc +align = + P.align + + +cat : List Doc -> Doc +cat = + P.cat + + +empty : Doc +empty = + P.empty + + +fill : Int -> Doc -> Doc +fill = + P.fill + + +fillSep : List Doc -> Doc +fillSep = + P.fillSep + + +hang : Int -> Doc -> Doc +hang = + P.hang + + +hcat : List Doc -> Doc +hcat = + P.hcat + + +hsep : List Doc -> Doc +hsep = + P.hsep + + +indent : Int -> Doc -> Doc +indent = + P.indent + + +sep : List Doc -> Doc +sep = + P.sep + + +vcat : List Doc -> Doc +vcat = + P.vcat + + +red : Doc -> Doc +red = + P.red + + +cyan : Doc -> Doc +cyan = + P.cyan + + +green : Doc -> Doc +green = + P.green + + +blue : Doc -> Doc +blue = + P.blue + + +black : Doc -> Doc +black = + P.black + + +yellow : Doc -> Doc +yellow = + P.yellow + + +dullred : Doc -> Doc +dullred = + P.dullred + + +dullcyan : Doc -> Doc +dullcyan = + P.dullcyan + + +dullyellow : Doc -> Doc +dullyellow = + P.dullyellow diff --git a/src/Compiler/Reporting/Error.elm b/src/Compiler/Reporting/Error.elm new file mode 100644 index 0000000000..b23bd1b128 --- /dev/null +++ b/src/Compiler/Reporting/Error.elm @@ -0,0 +1,343 @@ +module Compiler.Reporting.Error exposing + ( Error(..) + , Module + , moduleDecoder + , moduleEncoder + , toDoc + , toJson + ) + +import Builder.File as File +import Compiler.Data.NonEmptyList as NE +import Compiler.Data.OneOrMore as OneOrMore exposing (OneOrMore) +import Compiler.Elm.ModuleName as ModuleName +import Compiler.Json.Encode as E +import Compiler.Nitpick.PatternMatches as P +import Compiler.Parse.SyntaxVersion as SV exposing (SyntaxVersion) +import Compiler.Reporting.Annotation as A +import Compiler.Reporting.Doc as D +import Compiler.Reporting.Error.Canonicalize as Canonicalize +import Compiler.Reporting.Error.Docs as Docs +import Compiler.Reporting.Error.Import as Import +import Compiler.Reporting.Error.Main as Main +import Compiler.Reporting.Error.Pattern as Pattern +import Compiler.Reporting.Error.Syntax as Syntax +import Compiler.Reporting.Error.Type as Type +import Compiler.Reporting.Render.Code as Code +import Compiler.Reporting.Render.Type.Localizer as L +import Compiler.Reporting.Report as Report +import Time +import Utils.Bytes.Decode as BD +import Utils.Bytes.Encode as BE +import Utils.Main as Utils + + + +-- MODULE + + +type alias Module = + { name : ModuleName.Raw + , absolutePath : String + , modificationTime : File.Time + , source : String + , error : Error + } + + + +-- ERRORS + + +type Error + = BadSyntax Syntax.Error + | BadImports (NE.Nonempty Import.Error) + | BadNames (OneOrMore Canonicalize.Error) + | BadTypes L.Localizer (NE.Nonempty Type.Error) + | BadMains L.Localizer (OneOrMore Main.Error) + | BadPatterns (NE.Nonempty P.Error) + | BadDocs Docs.Error + + + +-- TO REPORT + + +toReports : SyntaxVersion -> Code.Source -> Error -> NE.Nonempty Report.Report +toReports syntaxVersion source err = + case err of + BadSyntax syntaxError -> + NE.singleton (Syntax.toReport syntaxVersion source syntaxError) + + BadImports errs -> + NE.map (Import.toReport source) errs + + BadNames errs -> + NE.map (Canonicalize.toReport source) (OneOrMore.destruct NE.Nonempty errs) + + BadTypes localizer errs -> + NE.map (Type.toReport source localizer) errs + + BadMains localizer errs -> + NE.map (Main.toReport localizer source) (OneOrMore.destruct NE.Nonempty errs) + + BadPatterns errs -> + NE.map (Pattern.toReport source) errs + + BadDocs docsErr -> + Docs.toReports source docsErr + + + +-- TO DOC + + +toDoc : String -> Module -> List Module -> D.Doc +toDoc root err errs = + let + (NE.Nonempty m ms) = + NE.sortBy + (\{ modificationTime } -> + let + (File.Time posix) = + modificationTime + in + Time.posixToMillis posix + ) + (NE.Nonempty err errs) + in + D.vcat (toDocHelp root m ms) + + +toDocHelp : String -> Module -> List Module -> List D.Doc +toDocHelp root module1 modules = + case modules of + [] -> + [ moduleToDoc root module1 + , D.fromChars "" + ] + + module2 :: otherModules -> + moduleToDoc root module1 + :: toSeparator module1 module2 + :: toDocHelp root module2 otherModules + + +toSeparator : Module -> Module -> D.Doc +toSeparator beforeModule afterModule = + let + before : ModuleName.Raw + before = + beforeModule.name ++ " ↑ " + + after : String + after = + " ↓ " ++ afterModule.name + in + D.dullred <| + D.vcat + [ D.indent (80 - String.length before) (D.fromChars before) + , D.fromChars "====o======================================================================o====" + , D.fromChars after + , D.empty + , D.empty + ] + + + +-- MODULE TO DOC + + +moduleToDoc : String -> Module -> D.Doc +moduleToDoc root { absolutePath, source, error } = + let + reports : NE.Nonempty Report.Report + reports = + toReports (SV.fileSyntaxVersion absolutePath) (Code.toSource source) error + + relativePath : Utils.FilePath + relativePath = + Utils.fpMakeRelative root absolutePath + in + D.vcat <| List.map (reportToDoc relativePath) (NE.toList reports) + + +reportToDoc : String -> Report.Report -> D.Doc +reportToDoc relativePath (Report.Report title _ _ message) = + D.vcat + [ toMessageBar title relativePath + , D.fromChars "" + , message + , D.fromChars "" + ] + + +toMessageBar : String -> String -> D.Doc +toMessageBar title filePath = + let + usedSpace : Int + usedSpace = + 4 + String.length title + 1 + String.length filePath + in + D.dullcyan <| + D.fromChars <| + "-- " + ++ title + ++ " " + ++ String.repeat (max 1 (80 - usedSpace)) "-" + ++ " " + ++ filePath + + + +-- TO JSON + + +toJson : Module -> E.Value +toJson { name, absolutePath, source, error } = + let + reports : NE.Nonempty Report.Report + reports = + toReports (SV.fileSyntaxVersion absolutePath) (Code.toSource source) error + in + E.object + [ ( "path", E.string absolutePath ) + , ( "name", E.string name ) + , ( "problems", E.list reportToJson (NE.toList reports) ) + ] + + +reportToJson : Report.Report -> E.Value +reportToJson (Report.Report title region _ message) = + E.object + [ ( "title", E.string title ) + , ( "region", encodeRegion region ) + , ( "message", D.encode message ) + ] + + +encodeRegion : A.Region -> E.Value +encodeRegion (A.Region (A.Position sr sc) (A.Position er ec)) = + E.object + [ ( "start" + , E.object + [ ( "line", E.int sr ) + , ( "column", E.int sc ) + ] + ) + , ( "end" + , E.object + [ ( "line", E.int er ) + , ( "column", E.int ec ) + ] + ) + ] + + + +-- ENCODERS and DECODERS + + +moduleEncoder : Module -> BE.Encoder +moduleEncoder modul = + BE.sequence + [ ModuleName.rawEncoder modul.name + , BE.string modul.absolutePath + , File.timeEncoder modul.modificationTime + , BE.string modul.source + , errorEncoder modul.error + ] + + +moduleDecoder : BD.Decoder Module +moduleDecoder = + BD.map5 Module + ModuleName.rawDecoder + BD.string + File.timeDecoder + BD.string + errorDecoder + + +errorEncoder : Error -> BE.Encoder +errorEncoder error = + case error of + BadSyntax syntaxError -> + BE.sequence + [ BE.unsignedInt8 0 + , Syntax.errorEncoder syntaxError + ] + + BadImports errs -> + BE.sequence + [ BE.unsignedInt8 1 + , BE.nonempty Import.errorEncoder errs + ] + + BadNames errs -> + BE.sequence + [ BE.unsignedInt8 2 + , BE.oneOrMore Canonicalize.errorEncoder errs + ] + + BadTypes localizer errs -> + BE.sequence + [ BE.unsignedInt8 3 + , L.localizerEncoder localizer + , BE.nonempty Type.errorEncoder errs + ] + + BadMains localizer errs -> + BE.sequence + [ BE.unsignedInt8 4 + , L.localizerEncoder localizer + , BE.oneOrMore Main.errorEncoder errs + ] + + BadPatterns errs -> + BE.sequence + [ BE.unsignedInt8 5 + , BE.nonempty P.errorEncoder errs + ] + + BadDocs docsErr -> + BE.sequence + [ BE.unsignedInt8 6 + , Docs.errorEncoder docsErr + ] + + +errorDecoder : BD.Decoder Error +errorDecoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.map BadSyntax Syntax.errorDecoder + + 1 -> + BD.map BadImports (BD.nonempty Import.errorDecoder) + + 2 -> + BD.map BadNames (BD.oneOrMore Canonicalize.errorDecoder) + + 3 -> + BD.map2 BadTypes + L.localizerDecoder + (BD.nonempty Type.errorDecoder) + + 4 -> + BD.map2 BadMains + L.localizerDecoder + (BD.oneOrMore Main.errorDecoder) + + 5 -> + BD.map BadPatterns (BD.nonempty P.errorDecoder) + + 6 -> + BD.map BadDocs Docs.errorDecoder + + _ -> + BD.fail + ) diff --git a/src/Compiler/Reporting/Error/Canonicalize.elm b/src/Compiler/Reporting/Error/Canonicalize.elm new file mode 100644 index 0000000000..d181d94ed5 --- /dev/null +++ b/src/Compiler/Reporting/Error/Canonicalize.elm @@ -0,0 +1,2102 @@ +module Compiler.Reporting.Error.Canonicalize exposing + ( BadArityContext(..) + , DuplicatePatternContext(..) + , Error(..) + , InvalidPayload(..) + , PortProblem(..) + , PossibleNames + , VarKind(..) + , errorDecoder + , errorEncoder + , invalidPayloadDecoder + , invalidPayloadEncoder + , toReport + ) + +import Compiler.AST.Canonical as Can +import Compiler.AST.Source as Src +import Compiler.Data.Index as Index +import Compiler.Data.Name as Name exposing (Name) +import Compiler.Data.OneOrMore as OneOrMore exposing (OneOrMore) +import Compiler.Elm.ModuleName as ModuleName +import Compiler.Reporting.Annotation as A +import Compiler.Reporting.Doc as D +import Compiler.Reporting.Render.Code as Code +import Compiler.Reporting.Render.Type as RT +import Compiler.Reporting.Report as Report +import Compiler.Reporting.Suggest as Suggest +import Data.Map as Dict exposing (Dict) +import Data.Set as EverySet exposing (EverySet) +import System.TypeCheck.IO as IO +import Utils.Bytes.Decode as BD +import Utils.Bytes.Encode as BE + + + +-- CANONICALIZATION ERRORS + + +type Error + = AnnotationTooShort A.Region Name Index.ZeroBased Int + | AmbiguousVar A.Region (Maybe Name) Name IO.Canonical (OneOrMore IO.Canonical) + | AmbiguousType A.Region (Maybe Name) Name IO.Canonical (OneOrMore IO.Canonical) + | AmbiguousVariant A.Region (Maybe Name) Name IO.Canonical (OneOrMore IO.Canonical) + | AmbiguousBinop A.Region Name IO.Canonical (OneOrMore IO.Canonical) + | BadArity A.Region BadArityContext Name Int Int + | Binop A.Region Name Name + | DuplicateDecl Name A.Region A.Region + | DuplicateType Name A.Region A.Region + | DuplicateCtor Name A.Region A.Region + | DuplicateBinop Name A.Region A.Region + | DuplicateField Name A.Region A.Region + | DuplicateAliasArg Name Name A.Region A.Region + | DuplicateUnionArg Name Name A.Region A.Region + | DuplicatePattern DuplicatePatternContext Name A.Region A.Region + | EffectNotFound A.Region Name + | EffectFunctionNotFound A.Region Name + | ExportDuplicate Name A.Region A.Region + | ExportNotFound A.Region VarKind Name (List Name) + | ExportOpenAlias A.Region Name + | ImportCtorByName A.Region Name Name + | ImportNotFound A.Region Name (List IO.Canonical) + | ImportOpenAlias A.Region Name + | ImportExposingNotFound A.Region IO.Canonical Name (List Name) + | NotFoundVar A.Region (Maybe Name) Name PossibleNames + | NotFoundType A.Region (Maybe Name) Name PossibleNames + | NotFoundVariant A.Region (Maybe Name) Name PossibleNames + | NotFoundBinop A.Region Name (EverySet String Name) + | PatternHasRecordCtor A.Region Name + | PortPayloadInvalid A.Region Name Can.Type InvalidPayload + | PortTypeInvalid A.Region Name PortProblem + | RecursiveAlias A.Region Name (List Name) Src.Type (List Name) + | RecursiveDecl A.Region Name (List Name) + | RecursiveLet (A.Located Name) (List Name) + | Shadowing Name A.Region A.Region + | TupleLargerThanThree A.Region + | TypeVarsUnboundInUnion A.Region Name (List Name) ( Name, A.Region ) (List ( Name, A.Region )) + | TypeVarsMessedUpInAlias A.Region Name (List Name) (List ( Name, A.Region )) (List ( Name, A.Region )) + + +type BadArityContext + = TypeArity + | PatternArity + + +type DuplicatePatternContext + = DPLambdaArgs + | DPFuncArgs Name + | DPCaseBranch + | DPLetBinding + | DPDestruct + + +type InvalidPayload + = ExtendedRecord + | Function + | TypeVariable Name + | UnsupportedType Name + + +type PortProblem + = CmdNoArg + | CmdExtraArgs Int + | CmdBadMsg + | SubBad + | NotCmdOrSub + + +type alias PossibleNames = + { locals : EverySet String Name + , quals : Dict String Name (EverySet String Name) + } + + + +-- KIND + + +type VarKind + = BadOp + | BadVar + | BadPattern + | BadType + + +toKindInfo : VarKind -> Name -> ( D.Doc, D.Doc, D.Doc ) +toKindInfo kind name = + case kind of + BadOp -> + ( D.fromChars "an" + , D.fromChars "operator" + , D.fromChars "(" + |> D.a (D.fromName name) + |> D.a (D.fromChars ")") + ) + + BadVar -> + ( D.fromChars "a" + , D.fromChars "value" + , D.fromChars "`" + |> D.a (D.fromName name) + |> D.a (D.fromChars "`") + ) + + BadPattern -> + ( D.fromChars "a" + , D.fromChars "pattern" + , D.fromChars "`" + |> D.a (D.fromName name) + |> D.a (D.fromChars "`") + ) + + BadType -> + ( D.fromChars "a" + , D.fromChars "type" + , D.fromChars "`" + |> D.a (D.fromName name) + |> D.a (D.fromChars "`") + ) + + + +-- TO REPORT + + +toReport : Code.Source -> Error -> Report.Report +toReport source err = + case err of + AnnotationTooShort region name index leftovers -> + let + numTypeArgs : Int + numTypeArgs = + Index.toMachine index + + numDefArgs : Int + numDefArgs = + numTypeArgs + leftovers + in + Report.Report "BAD TYPE ANNOTATION" region [] <| + Code.toSnippet source + region + Nothing + ( D.reflow + ("The type annotation for `" + ++ name + ++ "` says it can accept " + ++ D.args numTypeArgs + ++ ", but the definition says it has " + ++ D.args numDefArgs + ++ ":" + ) + , D.reflow + ("Is the type annotation missing something? Should some argument" + ++ (if leftovers == 1 then + "" + + else + "s" + ) + ++ " be deleted? Maybe some parentheses are missing?" + ) + ) + + AmbiguousVar region maybePrefix name h hs -> + ambiguousName source region maybePrefix name h hs "variable" + + AmbiguousType region maybePrefix name h hs -> + ambiguousName source region maybePrefix name h hs "type" + + AmbiguousVariant region maybePrefix name h hs -> + ambiguousName source region maybePrefix name h hs "variant" + + AmbiguousBinop region name h hs -> + ambiguousName source region Nothing name h hs "operator" + + BadArity region badArityContext name expected actual -> + let + thing : String + thing = + case badArityContext of + TypeArity -> + "type" + + PatternArity -> + "variant" + in + if actual < expected then + Report.Report "TOO FEW ARGS" region [] <| + Code.toSnippet source + region + Nothing + ( D.reflow + ("The `" + ++ name + ++ "` " + ++ thing + ++ " needs " + ++ D.args expected + ++ ", but I see " + ++ String.fromInt actual + ++ " instead:" + ) + , D.reflow + "What is missing? Are some parentheses misplaced?" + ) + + else + Report.Report "TOO MANY ARGS" region [] <| + Code.toSnippet source + region + Nothing + ( D.reflow + ("The `" + ++ name + ++ "` " + ++ thing + ++ " needs " + ++ D.args expected + ++ ", but I see " + ++ String.fromInt actual + ++ " instead:" + ) + , if actual - expected == 1 then + D.fromChars "Which is the extra one? Maybe some parentheses are missing?" + + else + D.fromChars "Which are the extra ones? Maybe some parentheses are missing?" + ) + + Binop region op1 op2 -> + Report.Report "INFIX PROBLEM" region [] <| + Code.toSnippet source + region + Nothing + ( D.reflow + ("You cannot mix (" ++ op1 ++ ") and (" ++ op2 ++ ") without parentheses.") + , D.reflow + "I do not know how to group these expressions. Add parentheses for me!" + ) + + DuplicateDecl name r1 r2 -> + nameClash source r1 r2 <| + "This file has multiple `" + ++ name + ++ "` declarations." + + DuplicateType name r1 r2 -> + nameClash source r1 r2 <| + "This file defines multiple `" + ++ name + ++ "` types." + + DuplicateCtor name r1 r2 -> + nameClash source r1 r2 <| + "This file defines multiple `" + ++ name + ++ "` type constructors." + + DuplicateBinop name r1 r2 -> + nameClash source r1 r2 <| + "This file defines multiple (" + ++ name + ++ ") operators." + + DuplicateField name r1 r2 -> + nameClash source r1 r2 <| + "This record has multiple `" + ++ name + ++ "` fields." + + DuplicateAliasArg typeName name r1 r2 -> + nameClash source r1 r2 <| + "The `" + ++ typeName + ++ "` type alias has multiple `" + ++ name + ++ "` type variables." + + DuplicateUnionArg typeName name r1 r2 -> + nameClash source r1 r2 <| + "The `" + ++ typeName + ++ "` type has multiple `" + ++ name + ++ "` type variables." + + DuplicatePattern context name r1 r2 -> + nameClash source r1 r2 <| + case context of + DPLambdaArgs -> + "This anonymous function has multiple `" ++ name ++ "` arguments." + + DPFuncArgs funcName -> + "The `" ++ funcName ++ "` function has multiple `" ++ name ++ "` arguments." + + DPCaseBranch -> + "This `case` pattern has multiple `" ++ name ++ "` variables." + + DPLetBinding -> + "This `let` expression defines `" ++ name ++ "` more than once!" + + DPDestruct -> + "This pattern contains multiple `" ++ name ++ "` variables." + + EffectNotFound region name -> + Report.Report "EFFECT PROBLEM" region [] <| + Code.toSnippet source + region + Nothing + ( D.reflow + ("You have declared that `" ++ name ++ "` is an effect type:") + , D.reflow + ("But I cannot find a custom type named `" ++ name ++ "` in this file!") + ) + + EffectFunctionNotFound region name -> + Report.Report "EFFECT PROBLEM" region [] <| + Code.toSnippet source + region + Nothing + ( D.reflow + ("This kind of effect module must define a `" ++ name ++ "` function.") + , D.reflow + ("But I cannot find `" ++ name ++ "` in this file!") + ) + + ExportDuplicate name r1 r2 -> + let + messageThatEndsWithPunctuation : String + messageThatEndsWithPunctuation = + "You are trying to expose `" ++ name ++ "` multiple times!" + in + Report.Report "REDUNDANT EXPORT" r2 [] <| + Code.toPair source + r1 + r2 + ( D.reflow messageThatEndsWithPunctuation + , D.fromChars "Remove one of them and you should be all set!" + ) + ( D.reflow (messageThatEndsWithPunctuation ++ " Once here:") + , D.fromChars "And again right here:" + , D.fromChars "Remove one of them and you should be all set!" + ) + + ExportNotFound region kind rawName possibleNames -> + let + suggestions : List String + suggestions = + List.take 4 <| Suggest.sort rawName identity possibleNames + in + Report.Report "UNKNOWN EXPORT" region suggestions <| + let + ( a, thing, name ) = + toKindInfo kind rawName + in + D.stack + [ D.fillSep + [ D.fromChars "You" + , D.fromChars "are" + , D.fromChars "trying" + , D.fromChars "to" + , D.fromChars "expose" + , a + , thing + , D.fromChars "named" + , name + , D.fromChars "but" + , D.fromChars "I" + , D.fromChars "cannot" + , D.fromChars "find" + , D.fromChars "its" + , D.fromChars "definition." + ] + , case List.map D.fromChars suggestions of + [] -> + D.reflow "I do not see any super similar names in this file. Is the definition missing?" + + [ alt ] -> + D.fillSep + [ D.fromChars "Maybe" + , D.fromChars "you" + , D.fromChars "want" + , D.dullyellow alt + , D.fromChars "instead?" + ] + + alts -> + D.stack + [ D.fromChars "These names seem close though:" + , D.indent 4 <| D.vcat <| List.map D.dullyellow alts + ] + ] + + ExportOpenAlias region name -> + Report.Report "BAD EXPORT" region [] <| + Code.toSnippet source + region + Nothing + ( D.reflow + ("The (..) syntax is for exposing variants of a custom type. It cannot be used with a type alias like `" + ++ name + ++ "` though." + ) + , D.reflow + "Remove the (..) and you should be fine!" + ) + + ImportCtorByName region ctor tipe -> + Report.Report "BAD IMPORT" region [] <| + Code.toSnippet source + region + Nothing + ( D.reflow + ("You are trying to import the `" + ++ ctor + ++ "` variant by name:" + ) + , D.fillSep + [ D.fromChars "Try" + , D.fromChars "importing" + , D.green (D.fromName tipe |> D.a (D.fromChars "(..)")) + , D.fromChars "instead." + , D.fromChars "The" + , D.fromChars "dots" + , D.fromChars "mean" + , D.fromChars "“expose" + , D.fromChars "the" + , D.fromName tipe + , D.fromChars "type" + , D.fromChars "and" + , D.fromChars "all" + , D.fromChars "its" + , D.fromChars "variants" + , D.fromChars "so" + , D.fromChars "it" + , D.fromChars "gives" + , D.fromChars "you" + , D.fromChars "access" + , D.fromChars "to" + , D.fromName ctor |> D.a (D.fromChars ".") + ] + ) + + ImportNotFound region name _ -> + -- + -- NOTE: this should always be detected by `builder` + -- So this error should never actually get printed out. + -- + Report.Report "UNKNOWN IMPORT" region [] <| + Code.toSnippet source + region + Nothing + ( D.reflow + ("I could not find a `" ++ name ++ "` module to import!") + , D.empty + ) + + ImportOpenAlias region name -> + Report.Report "BAD IMPORT" region [] <| + Code.toSnippet source + region + Nothing + ( D.reflow + ("The `" ++ name ++ "` type alias cannot be followed by (..) like this:") + , D.reflow + "Remove the (..) and it should work." + ) + + ImportExposingNotFound region (IO.Canonical _ home) value possibleNames -> + let + suggestions : List String + suggestions = + List.take 4 <| Suggest.sort home identity possibleNames + in + Report.Report "BAD IMPORT" region suggestions <| + Code.toSnippet source + region + Nothing + ( D.reflow + ("The `" + ++ home + ++ "` module does not expose `" + ++ value + ++ "`:" + ) + , case List.map D.fromChars suggestions of + [] -> + D.fromChars "I cannot find any super similar exposed names. Maybe it is private?" + + [ alt ] -> + D.fillSep + [ D.fromChars "Maybe" + , D.fromChars "you" + , D.fromChars "want" + , D.dullyellow alt + , D.fromChars "instead?" + ] + + alts -> + D.stack + [ D.fromChars "These names seem close though:" + , D.indent 4 <| D.vcat <| List.map D.dullyellow alts + ] + ) + + NotFoundVar region prefix name possibleNames -> + notFound source region prefix name "variable" possibleNames + + NotFoundType region prefix name possibleNames -> + notFound source region prefix name "type" possibleNames + + NotFoundVariant region prefix name possibleNames -> + notFound source region prefix name "variant" possibleNames + + NotFoundBinop region op locals -> + if op == "===" then + Report.Report "UNKNOWN OPERATOR" region [ "==" ] <| + Code.toSnippet source + region + Nothing + ( D.fromChars "Elm does not have a (===) operator like JavaScript." + , D.fromChars "Switch to (==) instead." + ) + + else if op == "!=" || op == "!==" then + Report.Report "UNKNOWN OPERATOR" region [ "/=" ] <| + Code.toSnippet source + region + Nothing + ( D.reflow + "Elm uses a different name for the “not equal” operator:" + , D.stack + [ D.reflow "Switch to (/=) instead." + , D.toSimpleNote + ("Our (/=) operator is supposed to look like a real “not equal” sign (≠). I hope that history will remember (" + ++ op + ++ ") as a weird and temporary choice." + ) + ] + ) + + else if op == "**" then + Report.Report "UNKNOWN OPERATOR" region [ "^", "*" ] <| + Code.toSnippet source + region + Nothing + ( D.reflow + "I do not recognize the (**) operator:" + , D.reflow + "Switch to (^) for exponentiation. Or switch to (*) for multiplication." + ) + + else if op == "%" then + Report.Report "UNKNOWN OPERATOR" region [] <| + Code.toSnippet source + region + Nothing + ( D.reflow + "Elm does not use (%) as the remainder operator:" + , D.stack + [ D.reflow + "If you want the behavior of (%) like in JavaScript, switch to: " + , D.reflow + "If you want modular arithmetic like in math, switch to: " + , D.reflow + "The difference is how things work when negative numbers are involved." + ] + ) + + else + let + suggestions : List String + suggestions = + List.take 2 <| Suggest.sort op identity (EverySet.toList compare locals) + + format : D.Doc -> D.Doc + format altOp = + D.green + (D.fromChars "(" + |> D.a altOp + |> D.a (D.fromChars ")") + ) + in + Report.Report "UNKNOWN OPERATOR" region suggestions <| + Code.toSnippet source + region + Nothing + ( D.reflow + ("I do not recognize the (" ++ op ++ ") operator.") + , D.fillSep + ([ D.fromChars "Is" + , D.fromChars "there" + , D.fromChars "an" + , D.fromChars "`import`" + , D.fromChars "and" + , D.fromChars "`exposing`" + , D.fromChars "entry" + , D.fromChars "for" + , D.fromChars "it?" + ] + ++ (case List.map D.fromChars suggestions of + [] -> + [] + + alts -> + [ D.fromChars "Maybe", D.fromChars "you", D.fromChars "want" ] + ++ D.commaSep (D.fromChars "or") format alts + ++ [ D.fromChars "instead?" ] + ) + ) + ) + + PatternHasRecordCtor region name -> + Report.Report "BAD PATTERN" region [] <| + Code.toSnippet source + region + Nothing + ( D.reflow + ("You can construct records by using `" + ++ name + ++ "` as a function, but it is not available in pattern matching like this:" + ) + , D.reflow + "I recommend matching the record as a variable and unpacking it later." + ) + + PortPayloadInvalid region portName _ invalidPayload -> + let + formatDetails : ( String, D.Doc ) -> Report.Report + formatDetails ( aBadKindOfThing, elaboration ) = + Report.Report "PORT ERROR" region [] <| + Code.toSnippet source + region + Nothing + ( D.reflow + ("The `" ++ portName ++ "` port is trying to transmit " ++ aBadKindOfThing ++ ":") + , D.stack + [ elaboration + , D.link "Hint" + "Ports are not a traditional FFI, so if you have tons of annoying ports, definitely read" + "ports" + "to learn how they are meant to work. They require a different mindset!" + ] + ) + in + formatDetails <| + case invalidPayload of + ExtendedRecord -> + ( "an extended record" + , D.reflow + "But the exact shape of the record must be known at compile time. No type variables!" + ) + + Function -> + ( "a function" + , D.reflow + "But functions cannot be sent in and out ports. If we allowed functions in from JS they may perform some side-effects. If we let functions out, they could produce incorrect results because Elm optimizations assume there are no side-effects." + ) + + TypeVariable name -> + ( "an unspecified type" + , D.reflow + ("But type variables like `" ++ name ++ "` cannot flow through ports. I need to know exactly what type of data I am getting, so I can guarantee that unexpected data cannot sneak in and crash the Elm program.") + ) + + UnsupportedType name -> + ( "a `" ++ name ++ "` value" + , D.stack + [ D.reflow "I cannot handle that. The types that CAN flow in and out of Elm include:" + , D.indent 4 <| + D.reflow + "Ints, Floats, Bools, Strings, Maybes, Lists, Arrays, tuples, records, and JSON values." + , D.reflow + "Since JSON values can flow through, you can use JSON encoders and decoders to allow other types through as well. More advanced users often just do everything with encoders and decoders for more control and better errors." + ] + ) + + PortTypeInvalid region name portProblem -> + let + formatDetails : ( String, D.Doc ) -> Report.Report + formatDetails ( before, after ) = + Report.Report "BAD PORT" region [] <| + Code.toSnippet source + region + Nothing + ( D.reflow before + , D.stack + [ after + , D.link "Hint" + "Read" + "ports" + "for more advice. For example, do not end up with one port per JS function!" + ] + ) + in + formatDetails <| + case portProblem of + CmdNoArg -> + ( "The `" ++ name ++ "` port cannot be just a command." + , D.reflow + "It can be (() -> Cmd msg) if you just need to trigger a JavaScript function, but there is often a better way to set things up." + ) + + CmdExtraArgs n -> + ( "The `" ++ name ++ "` port can only send ONE value out to JavaScript." + , let + theseItemsInSomething : String + theseItemsInSomething = + if n == 2 then + "both of these items into a tuple or record" + + else if n == 3 then + "these " ++ String.fromInt n ++ " items into a tuple or record" + + else + "these " ++ String.fromInt n ++ " items into a record" + in + D.reflow <| "You can put " ++ theseItemsInSomething ++ " to send them out though." + ) + + CmdBadMsg -> + ( "The `" ++ name ++ "` port cannot send any messages to the `update` function." + , D.reflow + "It must produce a (Cmd msg) type. Notice the lower case `msg` type variable. The command will trigger some JS code, but it will not send anything particular back to Elm." + ) + + SubBad -> + ( "There is something off about this `" ++ name ++ "` port declaration." + , D.stack + [ D.reflow + "To receive messages from JavaScript, you need to define a port like this:" + , D.indent 4 <| D.dullyellow <| D.fromChars <| "port " ++ name ++ " : (Int -> msg) -> Sub msg" + , D.reflow + "Now every time JS sends an `Int` to this port, it is converted to a `msg`. And if you subscribe, those `msg` values will be piped into your `update` function. The only thing you can customize here is the `Int` type." + ] + ) + + NotCmdOrSub -> + ( "I am confused about the `" ++ name ++ "` port declaration." + , D.reflow + "Ports need to produce a command (Cmd) or a subscription (Sub) but this is neither. I do not know how to handle this." + ) + + RecursiveAlias region name args tipe others -> + aliasRecursionReport source region name args tipe others + + RecursiveDecl region name names -> + let + makeTheory : String -> String -> D.Doc + makeTheory question details = + D.fillSep <| List.map (D.dullyellow << D.fromChars) (String.words question) ++ List.map D.fromChars (String.words details) + in + Report.Report "CYCLIC DEFINITION" region [] <| + Code.toSnippet source region Nothing <| + case names of + [] -> + ( D.reflow <| "The `" ++ name ++ "` value is defined directly in terms of itself, causing an infinite loop." + , D.stack + [ makeTheory "Are you trying to mutate a variable?" <| "Elm does not have mutation, so when I see " ++ name ++ " defined in terms of " ++ name ++ ", I treat it as a recursive definition. Try giving the new value a new name!" + , makeTheory "Maybe you DO want a recursive value?" <| "To define " ++ name ++ " we need to know what " ++ name ++ " is, so let’s expand it. Wait, but now we need to know what " ++ name ++ " is, so let’s expand it... This will keep going infinitely!" + , D.link "Hint" "The root problem is often a typo in some variable name, but I recommend reading" "bad-recursion" "for more detailed advice, especially if you actually do need a recursive value." + ] + ) + + _ :: _ -> + ( D.reflow <| "The `" ++ name ++ "` definition is causing a very tricky infinite loop." + , D.stack + [ D.reflow <| "The `" ++ name ++ "` value depends on itself through the following chain of definitions:" + , D.cycle 4 name names + , D.link "Hint" "The root problem is often a typo in some variable name, but I recommend reading" "bad-recursion" "for more detailed advice, especially if you actually do want mutually recursive values." + ] + ) + + RecursiveLet (A.At region name) names -> + Report.Report "CYCLIC VALUE" region [] <| + Code.toSnippet source region Nothing <| + case names of + [] -> + let + makeTheory : String -> String -> D.Doc + makeTheory question details = + D.fillSep <| List.map (D.dullyellow << D.fromChars) (String.words question) ++ List.map D.fromChars (String.words details) + in + ( D.reflow <| "The `" ++ name ++ "` value is defined directly in terms of itself, causing an infinite loop." + , D.stack + [ makeTheory "Are you trying to mutate a variable?" <| "Elm does not have mutation, so when I see " ++ name ++ " defined in terms of " ++ name ++ ", I treat it as a recursive definition. Try giving the new value a new name!" + , makeTheory "Maybe you DO want a recursive value?" <| "To define " ++ name ++ " we need to know what " ++ name ++ " is, so let’s expand it. Wait, but now we need to know what " ++ name ++ " is, so let’s expand it... This will keep going infinitely!" + , D.link "Hint" "The root problem is often a typo in some variable name, but I recommend reading" "bad-recursion" "for more detailed advice, especially if you actually do need a recursive value." + ] + ) + + _ -> + ( D.reflow <| "I do not allow cyclic values in `let` expressions." + , D.stack + [ D.reflow <| "The `" ++ name ++ "` value depends on itself through the following chain of definitions:" + , D.cycle 4 name names + , D.link "Hint" "The root problem is often a typo in some variable name, but I recommend reading" "bad-recursion" "for more detailed advice, especially if you actually do want mutually recursive values." + ] + ) + + Shadowing name r1 r2 -> + let + advice : D.Doc + advice = + D.stack + [ D.reflow <| "Think of a more helpful name for one of them and you should be all set!" + , D.link "Note" "Linters advise against shadowing, so Elm makes “best practices” the default. Read" "shadowing" "for more details on this choice." + ] + in + Report.Report "SHADOWING" r2 [] <| + Code.toPair source + r1 + r2 + ( D.fromChars "These variables cannot have the same name:" + , advice + ) + ( D.reflow <| "The name `" ++ name ++ "` is first defined here:" + , D.fromChars "But then it is defined AGAIN over here:" + , advice + ) + + TupleLargerThanThree region -> + Report.Report "BAD TUPLE" region [] <| + Code.toSnippet source + region + Nothing + ( D.fromChars "I only accept tuples with two or three items. This has too many:" + , D.stack + [ D.reflow <| "I recommend switching to records. Each item will be named, and you can use the `point.x` syntax to access them." + , D.link "Note" "Read" "tuples" "for more comprehensive advice on working with large chunks of data in Elm." + ] + ) + + TypeVarsUnboundInUnion unionRegion typeName allVars unbound unbounds -> + unboundTypeVars source unionRegion [ D.fromChars "type" ] typeName allVars unbound unbounds + + TypeVarsMessedUpInAlias aliasRegion typeName allVars unusedVars unboundVars -> + case ( unusedVars, unboundVars ) of + ( unused :: unuseds, [] ) -> + let + backQuote : Name -> D.Doc + backQuote name = + D.fromChars "`" + |> D.a (D.fromName name) + |> D.a (D.fromChars "`") + + allUnusedNames : List Name + allUnusedNames = + List.map Tuple.first unusedVars + + ( ( title, subRegion ), ( overview, stuff ) ) = + case unuseds of + [] -> + ( ( "UNUSED TYPE VARIABLE" + , Just (Tuple.second unused) + ) + , ( [ D.fromChars "Type" + , D.fromChars "alias" + , backQuote typeName + , D.fromChars "does" + , D.fromChars "not" + , D.fromChars "use" + , D.fromChars "the" + , backQuote (Tuple.first unused) + , D.fromChars "type" + , D.fromChars "variable." + ] + , [ D.dullyellow (backQuote (Tuple.first unused)) ] + ) + ) + + _ :: _ -> + ( ( "UNUSED TYPE VARIABLES" + , Nothing + ) + , ( [ D.fromChars "Type", D.fromChars "variables" ] + ++ D.commaSep (D.fromChars "and") identity (List.map D.fromName allUnusedNames) + ++ [ D.fromChars "are" + , D.fromChars "unused" + , D.fromChars "in" + , D.fromChars "the" + , backQuote typeName + , D.fromChars "definition." + ] + , D.commaSep (D.fromChars "and") D.dullyellow (List.map D.fromName allUnusedNames) + ) + ) + in + Report.Report title aliasRegion [] <| + Code.toSnippet source + aliasRegion + subRegion + ( D.fillSep overview + , D.stack + [ D.fillSep <| [ D.fromChars "I", D.fromChars "recommend", D.fromChars "removing" ] ++ stuff ++ [ D.fromChars "from", D.fromChars "the", D.fromChars "declaration,", D.fromChars "like", D.fromChars "this:" ] + , D.indent 4 <| D.hsep <| [ D.fromChars "type", D.fromChars "alias", D.green (D.fromName typeName) ] ++ List.map D.fromName (List.filter (\var -> not (List.member var allUnusedNames)) allVars) ++ [ D.fromChars "=", D.fromChars "..." ] + , D.reflow <| "Why? Well, if I allowed `type alias Height a = Float` I would need to answer some weird questions. Is `Height Bool` the same as `Float`? Is `Height Bool` the same as `Height Int`? My solution is to not need to ask them!" + ] + ) + + ( [], unbound :: unbounds ) -> + unboundTypeVars source aliasRegion [ D.fromChars "type", D.fromChars "alias" ] typeName allVars unbound unbounds + + _ -> + let + unused : List Name + unused = + List.map Tuple.first unusedVars + + unbound : List Name + unbound = + List.map Tuple.first unboundVars + + theseAreUsed : List D.Doc + theseAreUsed = + case unbound of + [ x ] -> + [ D.fromChars "Type" + , D.fromChars "variable" + , D.dullyellow + (D.fromChars "`" + |> D.a (D.fromName x) + |> D.a (D.fromChars "`") + ) + , D.fromChars "appears" + , D.fromChars "in" + , D.fromChars "the" + , D.fromChars "definition," + , D.fromChars "but" + , D.fromChars "I" + , D.fromChars "do" + , D.fromChars "not" + , D.fromChars "see" + , D.fromChars "it" + , D.fromChars "declared." + ] + + _ -> + [ D.fromChars "Type", D.fromChars "variables" ] + ++ D.commaSep (D.fromChars "and") D.dullyellow (List.map D.fromName unbound) + ++ [ D.fromChars "are" + , D.fromChars "used" + , D.fromChars "in" + , D.fromChars "the" + , D.fromChars "definition," + , D.fromChars "but" + , D.fromChars "I" + , D.fromChars "do" + , D.fromChars "not" + , D.fromChars "see" + , D.fromChars "them" + , D.fromChars "declared." + ] + + butTheseAreUnused : List D.Doc + butTheseAreUnused = + case unused of + [ x ] -> + [ D.fromChars "Likewise," + , D.fromChars "type" + , D.fromChars "variable" + , D.dullyellow + (D.fromChars "`" + |> D.a (D.fromName x) + |> D.a (D.fromChars "`") + ) + , D.fromChars "is" + , D.fromChars "delared," + , D.fromChars "but" + , D.fromChars "not" + , D.fromChars "used." + ] + + _ -> + [ D.fromChars "Likewise,", D.fromChars "type", D.fromChars "variables" ] + ++ D.commaSep (D.fromChars "and") D.dullyellow (List.map D.fromName unused) + ++ [ D.fromChars "are", D.fromChars "delared,", D.fromChars "but", D.fromChars "not", D.fromChars "used." ] + in + Report.Report "TYPE VARIABLE PROBLEMS" aliasRegion [] <| + Code.toSnippet source + aliasRegion + Nothing + ( D.reflow <| "Type alias `" ++ typeName ++ "` has some type variable problems." + , D.stack + [ D.fillSep <| theseAreUsed ++ butTheseAreUnused + , D.reflow <| "My guess is that a definition like this will work better:" + , D.indent 4 <| D.hsep <| [ D.fromChars "type", D.fromChars "alias", D.fromName typeName ] ++ List.map D.fromName (List.filter (\var -> not (List.member var unused)) allVars) ++ List.map (D.green << D.fromName) unbound ++ [ D.fromChars "=", D.fromChars "..." ] + ] + ) + + +unboundTypeVars : Code.Source -> A.Region -> List D.Doc -> Name.Name -> List Name.Name -> ( Name.Name, A.Region ) -> List ( Name.Name, A.Region ) -> Report.Report +unboundTypeVars source declRegion tipe typeName allVars ( unboundVar, varRegion ) unboundVars = + let + backQuote : Name -> D.Doc + backQuote name = + D.fromChars "`" + |> D.a (D.fromName name) + |> D.a (D.fromChars "`") + + ( title, subRegion, overview ) = + case List.map Tuple.first unboundVars of + [] -> + ( "UNBOUND TYPE VARIABLE" + , Just varRegion + , [ D.fromChars "The", backQuote typeName ] + ++ tipe + ++ [ D.fromChars "uses" + , D.fromChars "an" + , D.fromChars "unbound" + , D.fromChars "type" + , D.fromChars "variable" + , D.dullyellow (backQuote unboundVar) + , D.fromChars "in" + , D.fromChars "its" + , D.fromChars "definition:" + ] + ) + + vars -> + ( "UNBOUND TYPE VARIABLES" + , Nothing + , [ D.fromChars "Type", D.fromChars "variables" ] + ++ D.commaSep (D.fromChars "and") D.dullyellow (D.fromName unboundVar :: List.map D.fromName vars) + ++ [ D.fromChars "are" + , D.fromChars "unbound" + , D.fromChars "in" + , D.fromChars "the" + , backQuote typeName + ] + ++ tipe + ++ [ D.fromChars "definition:" ] + ) + in + Report.Report title declRegion [] <| + Code.toSnippet source + declRegion + subRegion + ( D.fillSep overview + , D.stack + [ D.reflow "You probably need to change the declaration to something like this:" + , D.indent 4 <| + D.hsep <| + tipe + ++ D.fromName typeName + :: List.map D.fromName allVars + ++ List.map (D.green << D.fromName) (unboundVar :: List.map Tuple.first unboundVars) + ++ [ D.fromChars "=", D.fromChars "..." ] + , D.reflow <| + "Why? Well, imagine one `" + ++ typeName + ++ "` where `" + ++ unboundVar + ++ "` is an Int and another where it is a Bool. When we explicitly list the type variables, the type checker can see that they are actually different types." + ] + ) + + +nameClash : Code.Source -> A.Region -> A.Region -> String -> Report.Report +nameClash source r1 r2 messageThatEndsWithPunctuation = + Report.Report "NAME CLASH" r2 [] <| + Code.toPair source + r1 + r2 + ( D.reflow messageThatEndsWithPunctuation + , D.fromChars "How can I know which one you want? Rename one of them!" + ) + ( D.reflow (messageThatEndsWithPunctuation ++ " One here:") + , D.fromChars "And another one here:" + , D.fromChars "How can I know which one you want? Rename one of them!" + ) + + +ambiguousName : Code.Source -> A.Region -> Maybe Name.Name -> Name.Name -> IO.Canonical -> OneOrMore.OneOrMore IO.Canonical -> String -> Report.Report +ambiguousName source region maybePrefix name h hs thing = + let + possibleHomes : List IO.Canonical + possibleHomes = + List.sortWith ModuleName.compareCanonical (h :: OneOrMore.destruct (::) hs) + in + Report.Report "AMBIGUOUS NAME" region [] <| + Code.toSnippet source region Nothing <| + case maybePrefix of + Nothing -> + let + homeToYellowDoc : IO.Canonical -> D.Doc + homeToYellowDoc (IO.Canonical _ home) = + D.dullyellow + (D.fromName home + |> D.a (D.fromChars ".") + |> D.a (D.fromName name) + ) + in + ( D.reflow ("This usage of `" ++ name ++ "` is ambiguous:") + , D.stack + [ D.reflow <| + "This name is exposed by " + ++ String.fromInt (List.length possibleHomes) + ++ " of your imports, so I am not sure which one to use:" + , D.indent 4 <| D.vcat (List.map homeToYellowDoc possibleHomes) + , D.reflow "I recommend using qualified names for imported values. I also recommend having at most one `exposing (..)` per file to make name clashes like this less common in the long run." + , D.link "Note" "Check out" "imports" "for more info on the import syntax." + ] + ) + + Just prefix -> + let + homeToYellowDoc : IO.Canonical -> D.Doc + homeToYellowDoc (IO.Canonical _ home) = + if prefix == home then + D.cyan (D.fromChars "import") + |> D.plus (D.fromName home) + + else + D.cyan (D.fromChars "import") + |> D.plus (D.fromName home) + |> D.plus (D.cyan (D.fromChars "as")) + |> D.plus (D.fromName prefix) + + eitherOrAny : String + eitherOrAny = + if List.length possibleHomes == 2 then + "either" + + else + "any" + in + ( D.reflow ("This usage of `" ++ toQualString prefix name ++ "` is ambiguous.") + , D.stack + [ D.reflow <| + "It could refer to a " + ++ thing + ++ " from " + ++ eitherOrAny + ++ " of these imports:" + , D.indent 4 <| D.vcat (List.map homeToYellowDoc possibleHomes) + , D.reflowLink "Read" "imports" "to learn how to clarify which one you want." + ] + ) + + +notFound : Code.Source -> A.Region -> Maybe Name.Name -> Name.Name -> String -> PossibleNames -> Report.Report +notFound source region maybePrefix name thing { locals, quals } = + let + givenName : Name + givenName = + Maybe.withDefault name (Maybe.map2 toQualString maybePrefix (Just name)) + + possibleNames : List String + possibleNames = + let + addQuals : Name -> EverySet String Name -> List String -> List String + addQuals prefix localSet allNames = + EverySet.foldr compare (\x xs -> toQualString prefix x :: xs) allNames localSet + in + Dict.foldr compare addQuals (EverySet.toList compare locals) quals + + nearbyNames : List String + nearbyNames = + List.take 4 (Suggest.sort givenName identity possibleNames) + + toDetails : String -> String -> D.Doc + toDetails noSuggestionDetails yesSuggestionDetails = + case nearbyNames of + [] -> + D.stack + [ D.reflow noSuggestionDetails + , D.link "Hint" "Read" "imports" "to see how `import` declarations work in Elm." + ] + + suggestions -> + D.stack + [ D.reflow yesSuggestionDetails + , D.indent 4 <| D.vcat (List.map D.dullyellow (List.map D.fromChars suggestions)) + , D.link "Hint" "Read" "imports" "to see how `import` declarations work in Elm." + ] + in + Report.Report "NAMING ERROR" region nearbyNames <| + Code.toSnippet source + region + Nothing + ( D.reflow ("I cannot find a `" ++ givenName ++ "` " ++ thing ++ ":") + , case maybePrefix of + Nothing -> + toDetails + "Is there an `import` or `exposing` missing up top?" + "These names seem close though:" + + Just prefix -> + case Dict.get identity prefix quals of + Nothing -> + toDetails + ("I cannot find a `" ++ prefix ++ "` module. Is there an `import` for it?") + ("I cannot find a `" ++ prefix ++ "` import. These names seem close though:") + + Just _ -> + toDetails + ("The `" ++ prefix ++ "` module does not expose a `" ++ name ++ "` " ++ thing ++ ".") + ("The `" ++ prefix ++ "` module does not expose a `" ++ name ++ "` " ++ thing ++ ". These names seem close though:") + ) + + +toQualString : Name.Name -> Name.Name -> String +toQualString prefix name = + prefix ++ "." ++ name + + + +-- BAD ALIAS RECURSION + + +aliasRecursionReport : Code.Source -> A.Region -> Name -> List Name -> Src.Type -> List Name -> Report.Report +aliasRecursionReport source region name args tipe others = + case others of + [] -> + Report.Report "ALIAS PROBLEM" region [] <| + Code.toSnippet source + region + Nothing + ( D.fromChars "This type alias is recursive, forming an infinite type!" + , D.stack + [ D.reflow "When I expand a recursive type alias, it just keeps getting bigger and bigger. So dealiasing results in an infinitely large type! Try this instead:" + , D.indent 4 <| aliasToUnionDoc name args tipe + , D.link "Hint" "This is kind of a subtle distinction. I suggested the naive fix, but I recommend reading" "recursive-alias" "for ideas on how to do better." + ] + ) + + _ -> + Report.Report "ALIAS PROBLEM" region [] <| + Code.toSnippet source + region + Nothing + ( D.fromChars "This type alias is part of a mutually recursive set of type aliases." + , D.stack + [ D.fromChars "It is part of this cycle of type aliases:" + , D.cycle 4 name others + , D.reflow "You need to convert at least one of these type aliases into a `type`." + , D.link "Note" "Read" "recursive-alias" "to learn why this `type` vs `type alias` distinction matters. It is subtle but important!" + ] + ) + + +aliasToUnionDoc : Name -> List Name -> Src.Type -> D.Doc +aliasToUnionDoc name args tipe = + D.vcat + [ D.dullyellow <| + (D.fromChars "type " + |> D.plus (D.fromName name) + |> D.plus (List.foldr D.plus (D.fromChars "=") (List.map D.fromName args)) + ) + , D.green <| D.indent 4 (D.fromChars name) + , D.dullyellow <| D.indent 8 (RT.srcToDoc RT.App tipe) + ] + + + +-- ENCODERS and DECODERS + + +errorEncoder : Error -> BE.Encoder +errorEncoder error = + case error of + AnnotationTooShort region name index leftovers -> + BE.sequence + [ BE.unsignedInt8 0 + , A.regionEncoder region + , BE.string name + , Index.zeroBasedEncoder index + , BE.int leftovers + ] + + AmbiguousVar region maybePrefix name h hs -> + BE.sequence + [ BE.unsignedInt8 1 + , A.regionEncoder region + , BE.maybe BE.string maybePrefix + , BE.string name + , ModuleName.canonicalEncoder h + , BE.oneOrMore ModuleName.canonicalEncoder hs + ] + + AmbiguousType region maybePrefix name h hs -> + BE.sequence + [ BE.unsignedInt8 2 + , A.regionEncoder region + , BE.maybe BE.string maybePrefix + , BE.string name + , ModuleName.canonicalEncoder h + , BE.oneOrMore ModuleName.canonicalEncoder hs + ] + + AmbiguousVariant region maybePrefix name h hs -> + BE.sequence + [ BE.unsignedInt8 3 + , A.regionEncoder region + , BE.maybe BE.string maybePrefix + , BE.string name + , ModuleName.canonicalEncoder h + , BE.oneOrMore ModuleName.canonicalEncoder hs + ] + + AmbiguousBinop region name h hs -> + BE.sequence + [ BE.unsignedInt8 4 + , A.regionEncoder region + , BE.string name + , ModuleName.canonicalEncoder h + , BE.oneOrMore ModuleName.canonicalEncoder hs + ] + + BadArity region badArityContext name expected actual -> + BE.sequence + [ BE.unsignedInt8 5 + , A.regionEncoder region + , badArityContextEncoder badArityContext + , BE.string name + , BE.int expected + , BE.int actual + ] + + Binop region op1 op2 -> + BE.sequence + [ BE.unsignedInt8 6 + , A.regionEncoder region + , BE.string op1 + , BE.string op2 + ] + + DuplicateDecl name r1 r2 -> + BE.sequence + [ BE.unsignedInt8 7 + , BE.string name + , A.regionEncoder r1 + , A.regionEncoder r2 + ] + + DuplicateType name r1 r2 -> + BE.sequence + [ BE.unsignedInt8 8 + , BE.string name + , A.regionEncoder r1 + , A.regionEncoder r2 + ] + + DuplicateCtor name r1 r2 -> + BE.sequence + [ BE.unsignedInt8 9 + , BE.string name + , A.regionEncoder r1 + , A.regionEncoder r2 + ] + + DuplicateBinop name r1 r2 -> + BE.sequence + [ BE.unsignedInt8 10 + , BE.string name + , A.regionEncoder r1 + , A.regionEncoder r2 + ] + + DuplicateField name r1 r2 -> + BE.sequence + [ BE.unsignedInt8 11 + , BE.string name + , A.regionEncoder r1 + , A.regionEncoder r2 + ] + + DuplicateAliasArg typeName name r1 r2 -> + BE.sequence + [ BE.unsignedInt8 12 + , BE.string typeName + , BE.string name + , A.regionEncoder r1 + , A.regionEncoder r2 + ] + + DuplicateUnionArg typeName name r1 r2 -> + BE.sequence + [ BE.unsignedInt8 13 + , BE.string typeName + , BE.string name + , A.regionEncoder r1 + , A.regionEncoder r2 + ] + + DuplicatePattern context name r1 r2 -> + BE.sequence + [ BE.unsignedInt8 14 + , duplicatePatternContextEncoder context + , BE.string name + , A.regionEncoder r1 + , A.regionEncoder r2 + ] + + EffectNotFound region name -> + BE.sequence + [ BE.unsignedInt8 15 + , A.regionEncoder region + , BE.string name + ] + + EffectFunctionNotFound region name -> + BE.sequence + [ BE.unsignedInt8 16 + , A.regionEncoder region + , BE.string name + ] + + ExportDuplicate name r1 r2 -> + BE.sequence + [ BE.unsignedInt8 17 + , BE.string name + , A.regionEncoder r1 + , A.regionEncoder r2 + ] + + ExportNotFound region kind rawName possibleNames -> + BE.sequence + [ BE.unsignedInt8 18 + , A.regionEncoder region + , varKindEncoder kind + , BE.string rawName + , BE.list BE.string possibleNames + ] + + ExportOpenAlias region name -> + BE.sequence + [ BE.unsignedInt8 19 + , A.regionEncoder region + , BE.string name + ] + + ImportCtorByName region ctor tipe -> + BE.sequence + [ BE.unsignedInt8 20 + , A.regionEncoder region + , BE.string ctor + , BE.string tipe + ] + + ImportNotFound region name suggestions -> + BE.sequence + [ BE.unsignedInt8 21 + , A.regionEncoder region + , BE.string name + , BE.list ModuleName.canonicalEncoder suggestions + ] + + ImportOpenAlias region name -> + BE.sequence + [ BE.unsignedInt8 22 + , A.regionEncoder region + , BE.string name + ] + + ImportExposingNotFound region home value possibleNames -> + BE.sequence + [ BE.unsignedInt8 23 + , A.regionEncoder region + , ModuleName.canonicalEncoder home + , BE.string value + , BE.list BE.string possibleNames + ] + + NotFoundVar region prefix name possibleNames -> + BE.sequence + [ BE.unsignedInt8 24 + , A.regionEncoder region + , BE.maybe BE.string prefix + , BE.string name + , possibleNamesEncoder possibleNames + ] + + NotFoundType region prefix name possibleNames -> + BE.sequence + [ BE.unsignedInt8 25 + , A.regionEncoder region + , BE.maybe BE.string prefix + , BE.string name + , possibleNamesEncoder possibleNames + ] + + NotFoundVariant region prefix name possibleNames -> + BE.sequence + [ BE.unsignedInt8 26 + , A.regionEncoder region + , BE.maybe BE.string prefix + , BE.string name + , possibleNamesEncoder possibleNames + ] + + NotFoundBinop region op locals -> + BE.sequence + [ BE.unsignedInt8 27 + , A.regionEncoder region + , BE.string op + , BE.everySet compare BE.string locals + ] + + PatternHasRecordCtor region name -> + BE.sequence + [ BE.unsignedInt8 28 + , A.regionEncoder region + , BE.string name + ] + + PortPayloadInvalid region portName badType invalidPayload -> + BE.sequence + [ BE.unsignedInt8 29 + , A.regionEncoder region + , BE.string portName + , Can.typeEncoder badType + , invalidPayloadEncoder invalidPayload + ] + + PortTypeInvalid region name portProblem -> + BE.sequence + [ BE.unsignedInt8 30 + , A.regionEncoder region + , BE.string name + , portProblemEncoder portProblem + ] + + RecursiveAlias region name args tipe others -> + BE.sequence + [ BE.unsignedInt8 31 + , A.regionEncoder region + , BE.string name + , BE.list BE.string args + , Src.typeEncoder tipe + , BE.list BE.string others + ] + + RecursiveDecl region name names -> + BE.sequence + [ BE.unsignedInt8 32 + , A.regionEncoder region + , BE.string name + , BE.list BE.string names + ] + + RecursiveLet name names -> + BE.sequence + [ BE.unsignedInt8 33 + , A.locatedEncoder BE.string name + , BE.list BE.string names + ] + + Shadowing name r1 r2 -> + BE.sequence + [ BE.unsignedInt8 34 + , BE.string name + , A.regionEncoder r1 + , A.regionEncoder r2 + ] + + TupleLargerThanThree region -> + BE.sequence + [ BE.unsignedInt8 35 + , A.regionEncoder region + ] + + TypeVarsUnboundInUnion unionRegion typeName allVars unbound unbounds -> + BE.sequence + [ BE.unsignedInt8 36 + , A.regionEncoder unionRegion + , BE.string typeName + , BE.list BE.string allVars + , BE.jsonPair BE.string A.regionEncoder unbound + , BE.list (BE.jsonPair BE.string A.regionEncoder) unbounds + ] + + TypeVarsMessedUpInAlias aliasRegion typeName allVars unusedVars unboundVars -> + BE.sequence + [ BE.unsignedInt8 37 + , A.regionEncoder aliasRegion + , BE.string typeName + , BE.list BE.string allVars + , BE.list (BE.jsonPair BE.string A.regionEncoder) unusedVars + , BE.list (BE.jsonPair BE.string A.regionEncoder) unboundVars + ] + + +errorDecoder : BD.Decoder Error +errorDecoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.map4 AnnotationTooShort + A.regionDecoder + BD.string + Index.zeroBasedDecoder + BD.int + + 1 -> + BD.map5 AmbiguousVar + A.regionDecoder + (BD.maybe BD.string) + BD.string + ModuleName.canonicalDecoder + (BD.oneOrMore ModuleName.canonicalDecoder) + + 2 -> + BD.map5 AmbiguousType + A.regionDecoder + (BD.maybe BD.string) + BD.string + ModuleName.canonicalDecoder + (BD.oneOrMore ModuleName.canonicalDecoder) + + 3 -> + BD.map5 AmbiguousVariant + A.regionDecoder + (BD.maybe BD.string) + BD.string + ModuleName.canonicalDecoder + (BD.oneOrMore ModuleName.canonicalDecoder) + + 4 -> + BD.map4 AmbiguousBinop + A.regionDecoder + BD.string + ModuleName.canonicalDecoder + (BD.oneOrMore ModuleName.canonicalDecoder) + + 5 -> + BD.map5 BadArity + A.regionDecoder + badArityContextDecoder + BD.string + BD.int + BD.int + + 6 -> + BD.map3 Binop + A.regionDecoder + BD.string + BD.string + + 7 -> + BD.map3 DuplicateDecl + BD.string + A.regionDecoder + A.regionDecoder + + 8 -> + BD.map3 DuplicateType + BD.string + A.regionDecoder + A.regionDecoder + + 9 -> + BD.map3 DuplicateCtor + BD.string + A.regionDecoder + A.regionDecoder + + 10 -> + BD.map3 DuplicateBinop + BD.string + A.regionDecoder + A.regionDecoder + + 11 -> + BD.map3 DuplicateField + BD.string + A.regionDecoder + A.regionDecoder + + 12 -> + BD.map4 DuplicateAliasArg + BD.string + BD.string + A.regionDecoder + A.regionDecoder + + 13 -> + BD.map4 DuplicateUnionArg + BD.string + BD.string + A.regionDecoder + A.regionDecoder + + 14 -> + BD.map4 DuplicatePattern + duplicatePatternContextDecoder + BD.string + A.regionDecoder + A.regionDecoder + + 15 -> + BD.map2 EffectNotFound + A.regionDecoder + BD.string + + 16 -> + BD.map2 EffectFunctionNotFound + A.regionDecoder + BD.string + + 17 -> + BD.map3 ExportDuplicate + BD.string + A.regionDecoder + A.regionDecoder + + 18 -> + BD.map4 ExportNotFound + A.regionDecoder + varKindDecoder + BD.string + (BD.list BD.string) + + 19 -> + BD.map2 ExportOpenAlias + A.regionDecoder + BD.string + + 20 -> + BD.map3 ImportCtorByName + A.regionDecoder + BD.string + BD.string + + 21 -> + BD.map3 ImportNotFound + A.regionDecoder + BD.string + (BD.list ModuleName.canonicalDecoder) + + 22 -> + BD.map2 ImportOpenAlias + A.regionDecoder + BD.string + + 23 -> + BD.map4 ImportExposingNotFound + A.regionDecoder + ModuleName.canonicalDecoder + BD.string + (BD.list BD.string) + + 24 -> + BD.map4 NotFoundVar + A.regionDecoder + (BD.maybe BD.string) + BD.string + possibleNamesDecoder + + 25 -> + BD.map4 NotFoundType + A.regionDecoder + (BD.maybe BD.string) + BD.string + possibleNamesDecoder + + 26 -> + BD.map4 NotFoundVariant + A.regionDecoder + (BD.maybe BD.string) + BD.string + possibleNamesDecoder + + 27 -> + BD.map3 NotFoundBinop + A.regionDecoder + BD.string + (BD.everySet identity BD.string) + + 28 -> + BD.map2 PatternHasRecordCtor + A.regionDecoder + BD.string + + 29 -> + BD.map4 PortPayloadInvalid + A.regionDecoder + BD.string + Can.typeDecoder + invalidPayloadDecoder + + 30 -> + BD.map3 PortTypeInvalid + A.regionDecoder + BD.string + portProblemDecoder + + 31 -> + BD.map5 RecursiveAlias + A.regionDecoder + BD.string + (BD.list BD.string) + Src.typeDecoder + (BD.list BD.string) + + 32 -> + BD.map3 RecursiveDecl + A.regionDecoder + BD.string + (BD.list BD.string) + + 33 -> + BD.map2 RecursiveLet + (A.locatedDecoder BD.string) + (BD.list BD.string) + + 34 -> + BD.map3 Shadowing + BD.string + A.regionDecoder + A.regionDecoder + + 35 -> + BD.map TupleLargerThanThree A.regionDecoder + + 36 -> + BD.map5 TypeVarsUnboundInUnion + A.regionDecoder + BD.string + (BD.list BD.string) + (BD.jsonPair BD.string A.regionDecoder) + (BD.list (BD.jsonPair BD.string A.regionDecoder)) + + 37 -> + BD.map5 TypeVarsMessedUpInAlias + A.regionDecoder + BD.string + (BD.list BD.string) + (BD.list (BD.jsonPair BD.string A.regionDecoder)) + (BD.list (BD.jsonPair BD.string A.regionDecoder)) + + _ -> + BD.fail + ) + + +badArityContextEncoder : BadArityContext -> BE.Encoder +badArityContextEncoder badArityContext = + BE.unsignedInt8 + (case badArityContext of + TypeArity -> + 0 + + PatternArity -> + 1 + ) + + +badArityContextDecoder : BD.Decoder BadArityContext +badArityContextDecoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.succeed TypeArity + + 1 -> + BD.succeed PatternArity + + _ -> + BD.fail + ) + + +duplicatePatternContextEncoder : DuplicatePatternContext -> BE.Encoder +duplicatePatternContextEncoder duplicatePatternContext = + case duplicatePatternContext of + DPLambdaArgs -> + BE.unsignedInt8 0 + + DPFuncArgs funcName -> + BE.sequence + [ BE.unsignedInt8 1 + , BE.string funcName + ] + + DPCaseBranch -> + BE.unsignedInt8 2 + + DPLetBinding -> + BE.unsignedInt8 3 + + DPDestruct -> + BE.unsignedInt8 4 + + +duplicatePatternContextDecoder : BD.Decoder DuplicatePatternContext +duplicatePatternContextDecoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.succeed DPLambdaArgs + + 1 -> + BD.map DPFuncArgs BD.string + + 2 -> + BD.succeed DPCaseBranch + + 3 -> + BD.succeed DPLetBinding + + 4 -> + BD.succeed DPDestruct + + _ -> + BD.fail + ) + + +varKindEncoder : VarKind -> BE.Encoder +varKindEncoder varKind = + BE.unsignedInt8 + (case varKind of + BadOp -> + 0 + + BadVar -> + 1 + + BadPattern -> + 2 + + BadType -> + 3 + ) + + +varKindDecoder : BD.Decoder VarKind +varKindDecoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.succeed BadOp + + 1 -> + BD.succeed BadVar + + 2 -> + BD.succeed BadPattern + + 3 -> + BD.succeed BadType + + _ -> + BD.fail + ) + + +possibleNamesEncoder : PossibleNames -> BE.Encoder +possibleNamesEncoder possibleNames = + BE.sequence + [ BE.everySet compare BE.string possibleNames.locals + , BE.assocListDict compare BE.string (BE.everySet compare BE.string) possibleNames.quals + ] + + +possibleNamesDecoder : BD.Decoder PossibleNames +possibleNamesDecoder = + BD.map2 PossibleNames + (BD.everySet identity BD.string) + (BD.assocListDict identity BD.string (BD.everySet identity BD.string)) + + +invalidPayloadEncoder : InvalidPayload -> BE.Encoder +invalidPayloadEncoder invalidPayload = + case invalidPayload of + ExtendedRecord -> + BE.unsignedInt8 0 + + Function -> + BE.unsignedInt8 1 + + TypeVariable name -> + BE.sequence + [ BE.unsignedInt8 2 + , BE.string name + ] + + UnsupportedType name -> + BE.sequence + [ BE.unsignedInt8 3 + , BE.string name + ] + + +invalidPayloadDecoder : BD.Decoder InvalidPayload +invalidPayloadDecoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.succeed ExtendedRecord + + 1 -> + BD.succeed Function + + 2 -> + BD.map TypeVariable BD.string + + 3 -> + BD.map UnsupportedType BD.string + + _ -> + BD.fail + ) + + +portProblemEncoder : PortProblem -> BE.Encoder +portProblemEncoder portProblem = + case portProblem of + CmdNoArg -> + BE.unsignedInt8 0 + + CmdExtraArgs n -> + BE.sequence + [ BE.unsignedInt8 1 + , BE.int n + ] + + CmdBadMsg -> + BE.unsignedInt8 2 + + SubBad -> + BE.unsignedInt8 3 + + NotCmdOrSub -> + BE.unsignedInt8 4 + + +portProblemDecoder : BD.Decoder PortProblem +portProblemDecoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.succeed CmdNoArg + + 1 -> + BD.map CmdExtraArgs BD.int + + 2 -> + BD.succeed CmdBadMsg + + 3 -> + BD.succeed SubBad + + 4 -> + BD.succeed NotCmdOrSub + + _ -> + BD.fail + ) diff --git a/src/Compiler/Reporting/Error/Docs.elm b/src/Compiler/Reporting/Error/Docs.elm new file mode 100644 index 0000000000..0a00116385 --- /dev/null +++ b/src/Compiler/Reporting/Error/Docs.elm @@ -0,0 +1,447 @@ +module Compiler.Reporting.Error.Docs exposing + ( DefProblem(..) + , Error(..) + , NameProblem(..) + , SyntaxProblem(..) + , errorDecoder + , errorEncoder + , toReports + ) + +import Compiler.Data.Name as Name +import Compiler.Data.NonEmptyList as NE +import Compiler.Parse.Primitives exposing (Col, Row) +import Compiler.Parse.Symbol as Symbol exposing (BadOperator) +import Compiler.Reporting.Annotation as A +import Compiler.Reporting.Doc as D +import Compiler.Reporting.Error.Syntax as E +import Compiler.Reporting.Render.Code as Code +import Compiler.Reporting.Report as Report +import Utils.Bytes.Decode as BD +import Utils.Bytes.Encode as BE + + +type Error + = NoDocs A.Region + | ImplicitExposing A.Region + | SyntaxProblem SyntaxProblem + | NameProblems (NE.Nonempty NameProblem) + | DefProblems (NE.Nonempty DefProblem) + + +type SyntaxProblem + = Op Row Col + | OpBad BadOperator Row Col + | Name Row Col + | Space E.Space Row Col + | Comma Row Col + | BadEnd Row Col + + +type NameProblem + = NameDuplicate Name.Name A.Region A.Region + | NameOnlyInDocs Name.Name A.Region + | NameOnlyInExports Name.Name A.Region + + +type DefProblem + = NoComment Name.Name A.Region + | NoAnnotation Name.Name A.Region + + +toReports : Code.Source -> Error -> NE.Nonempty Report.Report +toReports source err = + case err of + NoDocs region -> + NE.singleton <| + Report.Report "NO DOCS" region [] <| + Code.toSnippet source + region + Nothing + ( D.reflow "You must have a documentation comment between the module declaration and the imports." + , D.reflow "Learn more at " + ) + + ImplicitExposing region -> + NE.singleton <| + Report.Report "IMPLICIT EXPOSING" region [] <| + Code.toSnippet source + region + Nothing + ( D.reflow "I need you to be explicit about what this module exposes:" + , D.reflow "A great API usually hides some implementation details, so it is rare that everything in the file should be exposed. And requiring package authors to be explicit about this is a way of adding another quality check before code gets published. So as you write out the public API, ask yourself if it will be easy to understand as people read the documentation!" + ) + + SyntaxProblem problem -> + NE.singleton <| + toSyntaxProblemReport source problem + + NameProblems problems -> + NE.map (toNameProblemReport source) problems + + DefProblems problems -> + NE.map (toDefProblemReport source) problems + + +toSyntaxProblemReport : Code.Source -> SyntaxProblem -> Report.Report +toSyntaxProblemReport source problem = + let + toSyntaxReport : Row -> Col -> String -> Report.Report + toSyntaxReport row col details = + let + region : A.Region + region = + toRegion row col + in + Report.Report "PROBLEM IN DOCS" region [] <| + Code.toSnippet source + region + Nothing + ( D.reflow "I was partway through parsing your module documentation, but I got stuck here:" + , D.stack + [ D.reflow details + , D.toSimpleHint "Read through for tips on how to write module documentation!" + ] + ) + in + case problem of + Op row col -> + toSyntaxReport row col "I am trying to parse an operator like (+) or (*) but something is going wrong." + + OpBad _ row col -> + toSyntaxReport row col "I am trying to parse an operator like (+) or (*) but it looks like you are using a reserved symbol in this case." + + Name row col -> + toSyntaxReport row col "I was expecting to see the name of another exposed value from this module." + + Space space row col -> + E.toSpaceReport source space row col + + Comma row col -> + toSyntaxReport row col "I was expecting to see a comma next." + + BadEnd row col -> + toSyntaxReport row col "I am not really sure what I am getting stuck on though." + + +toRegion : Row -> Col -> A.Region +toRegion row col = + let + pos : A.Position + pos = + A.Position row col + in + A.Region pos pos + + +toNameProblemReport : Code.Source -> NameProblem -> Report.Report +toNameProblemReport source problem = + case problem of + NameDuplicate name r1 r2 -> + Report.Report "DUPLICATE DOCS" r2 [] <| + Code.toPair source + r1 + r2 + ( D.reflow ("There can only be one `" ++ name ++ "` in your module documentation, but it is listed twice:") + , D.fromChars "Remove one of them!" + ) + ( D.reflow ("There can only be one `" ++ name ++ "` in your module documentation, but I see two. One here:") + , D.fromChars "And another one over here:" + , D.fromChars "Remove one of them!" + ) + + NameOnlyInDocs name region -> + Report.Report "DOCS MISTAKE" region [] <| + Code.toSnippet source + region + Nothing + ( D.reflow ("I do not see `" ++ name ++ "` in the `exposing` list, but it is in your module documentation:") + , D.reflow ("Does it need to be added to the `exposing` list as well? Or maybe you removed `" ++ name ++ "` and forgot to delete it here?") + ) + + NameOnlyInExports name region -> + Report.Report "DOCS MISTAKE" region [] <| + Code.toSnippet source + region + Nothing + ( D.reflow ("I do not see `" ++ name ++ "` in your module documentation, but it is in your `exposing` list:") + , D.stack + [ D.reflow ("Add a line like `@docs " ++ name ++ "` to your module documentation!") + , D.link "Note" "See" "docs" "for more guidance on writing high quality docs." + ] + ) + + +toDefProblemReport : Code.Source -> DefProblem -> Report.Report +toDefProblemReport source problem = + case problem of + NoComment name region -> + Report.Report "NO DOCS" region [] <| + Code.toSnippet source + region + Nothing + ( D.reflow ("The `" ++ name ++ "` definition does not have a documentation comment.") + , D.stack + [ D.reflow "Add documentation with nice examples of how to use it!" + , D.link "Note" "Read" "docs" "for more advice on writing great docs. There are a couple important tricks!" + ] + ) + + NoAnnotation name region -> + Report.Report "NO TYPE ANNOTATION" region [] <| + Code.toSnippet source + region + Nothing + ( D.reflow ("The `" ++ name ++ "` definition does not have a type annotation.") + , D.stack + [ D.reflow "I use the type variable names from your annotations when generating docs. So if you say `Html msg` in your type annotation, I can use `msg` in the docs and make them a bit clearer. So add an annotation and try to use nice type variables!" + , D.link "Note" "Read" "docs" "for more advice on writing great docs. There are a couple important tricks!" + ] + ) + + + +-- ENCODERS and DECODERS + + +errorEncoder : Error -> BE.Encoder +errorEncoder error = + case error of + NoDocs region -> + BE.sequence + [ BE.unsignedInt8 0 + , A.regionEncoder region + ] + + ImplicitExposing region -> + BE.sequence + [ BE.unsignedInt8 1 + , A.regionEncoder region + ] + + SyntaxProblem problem -> + BE.sequence + [ BE.unsignedInt8 2 + , syntaxProblemEncoder problem + ] + + NameProblems problems -> + BE.sequence + [ BE.unsignedInt8 3 + , BE.nonempty nameProblemEncoder problems + ] + + DefProblems problems -> + BE.sequence + [ BE.unsignedInt8 4 + , BE.nonempty defProblemEncoder problems + ] + + +errorDecoder : BD.Decoder Error +errorDecoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.map NoDocs A.regionDecoder + + 1 -> + BD.map ImplicitExposing A.regionDecoder + + 2 -> + BD.map SyntaxProblem syntaxProblemDecoder + + 3 -> + BD.map NameProblems (BD.nonempty nameProblemDecoder) + + 4 -> + BD.map DefProblems (BD.nonempty defProblemDecoder) + + _ -> + BD.fail + ) + + +syntaxProblemEncoder : SyntaxProblem -> BE.Encoder +syntaxProblemEncoder syntaxProblem = + case syntaxProblem of + Op row col -> + BE.sequence + [ BE.unsignedInt8 0 + , BE.int row + , BE.int col + ] + + OpBad badOperator row col -> + BE.sequence + [ BE.unsignedInt8 1 + , Symbol.badOperatorEncoder badOperator + , BE.int row + , BE.int col + ] + + Name row col -> + BE.sequence + [ BE.unsignedInt8 2 + , BE.int row + , BE.int col + ] + + Space name row col -> + BE.sequence + [ BE.unsignedInt8 3 + , E.spaceEncoder name + , BE.int row + , BE.int col + ] + + Comma row col -> + BE.sequence + [ BE.unsignedInt8 4 + , BE.int row + , BE.int col + ] + + BadEnd row col -> + BE.sequence + [ BE.unsignedInt8 5 + , BE.int row + , BE.int col + ] + + +syntaxProblemDecoder : BD.Decoder SyntaxProblem +syntaxProblemDecoder = + BD.unsignedInt8 + |> BD.andThen + (\type_ -> + case type_ of + 0 -> + BD.map2 Op + BD.int + BD.int + + 1 -> + BD.map3 OpBad + Symbol.badOperatorDecoder + BD.int + BD.int + + 2 -> + BD.map2 Name + BD.int + BD.int + + 3 -> + BD.map3 Space + E.spaceDecoder + BD.int + BD.int + + 4 -> + BD.map2 Comma + BD.int + BD.int + + 5 -> + BD.map2 BadEnd + BD.int + BD.int + + _ -> + BD.fail + ) + + +nameProblemEncoder : NameProblem -> BE.Encoder +nameProblemEncoder nameProblem = + case nameProblem of + NameDuplicate name r1 r2 -> + BE.sequence + [ BE.unsignedInt8 0 + , BE.string name + , A.regionEncoder r1 + , A.regionEncoder r2 + ] + + NameOnlyInDocs name region -> + BE.sequence + [ BE.unsignedInt8 1 + , BE.string name + , A.regionEncoder region + ] + + NameOnlyInExports name region -> + BE.sequence + [ BE.unsignedInt8 2 + , BE.string name + , A.regionEncoder region + ] + + +nameProblemDecoder : BD.Decoder NameProblem +nameProblemDecoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.map3 NameDuplicate + BD.string + A.regionDecoder + A.regionDecoder + + 1 -> + BD.map2 NameOnlyInDocs + BD.string + A.regionDecoder + + 2 -> + BD.map2 NameOnlyInExports + BD.string + A.regionDecoder + + _ -> + BD.fail + ) + + +defProblemEncoder : DefProblem -> BE.Encoder +defProblemEncoder defProblem = + case defProblem of + NoComment name region -> + BE.sequence + [ BE.unsignedInt8 0 + , BE.string name + , A.regionEncoder region + ] + + NoAnnotation name region -> + BE.sequence + [ BE.unsignedInt8 1 + , BE.string name + , A.regionEncoder region + ] + + +defProblemDecoder : BD.Decoder DefProblem +defProblemDecoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.map2 NoComment + BD.string + A.regionDecoder + + 1 -> + BD.map2 NoAnnotation + BD.string + A.regionDecoder + + _ -> + BD.fail + ) diff --git a/src/Compiler/Reporting/Error/Import.elm b/src/Compiler/Reporting/Error/Import.elm new file mode 100644 index 0000000000..f61ba4225a --- /dev/null +++ b/src/Compiler/Reporting/Error/Import.elm @@ -0,0 +1,268 @@ +module Compiler.Reporting.Error.Import exposing + ( Error(..) + , Problem(..) + , errorDecoder + , errorEncoder + , problemDecoder + , problemEncoder + , toReport + ) + +import Compiler.Elm.ModuleName as ModuleName +import Compiler.Elm.Package as Pkg +import Compiler.Reporting.Annotation as A +import Compiler.Reporting.Doc as D +import Compiler.Reporting.Render.Code as Code +import Compiler.Reporting.Report as Report +import Compiler.Reporting.Suggest as Suggest +import Data.Map as Dict +import Data.Set as EverySet exposing (EverySet) +import Utils.Bytes.Decode as BD +import Utils.Bytes.Encode as BE + + + +-- ERROR + + +type Error + = Error A.Region ModuleName.Raw (EverySet String ModuleName.Raw) Problem + + +type Problem + = NotFound + | Ambiguous String (List String) Pkg.Name (List Pkg.Name) + | AmbiguousLocal String String (List String) + | AmbiguousForeign Pkg.Name Pkg.Name (List Pkg.Name) + + + +-- TO REPORT + + +toReport : Code.Source -> Error -> Report.Report +toReport source (Error region name unimportedModules problem) = + case problem of + NotFound -> + Report.Report "MODULE NOT FOUND" region [] <| + Code.toSnippet source + region + Nothing + ( D.reflow + ("You are trying to import a `" ++ name ++ "` module:") + , D.stack + [ D.reflow + "I checked the \"dependencies\" and \"source-directories\" listed in your elm.json, but I cannot find it! Maybe it is a typo for one of these names?" + , D.dullyellow <| + D.indent 4 <| + D.vcat <| + List.map D.fromName (toSuggestions name unimportedModules) + , case Dict.get identity name Pkg.suggestions of + Nothing -> + D.toSimpleHint + "If it is not a typo, check the \"dependencies\" and \"source-directories\" of your elm.json to make sure all the packages you need are listed there!" + + Just dependency -> + D.toFancyHint + [ D.fromChars "Maybe" + , D.fromChars "you" + , D.fromChars "want" + , D.fromChars "the" + , D.fromChars "`" + |> D.a (D.fromName name) + |> D.a (D.fromChars "`") + , D.fromChars "module" + , D.fromChars "defined" + , D.fromChars "in" + , D.fromChars "the" + , D.fromChars (Pkg.toChars dependency) + , D.fromChars "package?" + , D.fromChars "Running" + , D.green (D.fromChars ("elm install " ++ Pkg.toChars dependency)) + , D.fromChars "should" + , D.fromChars "make" + , D.fromChars "it" + , D.fromChars "available!" + ] + ] + ) + + Ambiguous path _ pkg _ -> + Report.Report "AMBIGUOUS IMPORT" region [] <| + Code.toSnippet source + region + Nothing + ( D.reflow + ("You are trying to import a `" ++ name ++ "` module:") + , D.stack + [ D.fillSep + [ D.fromChars "But" + , D.fromChars "I" + , D.fromChars "found" + , D.fromChars "multiple" + , D.fromChars "modules" + , D.fromChars "with" + , D.fromChars "that" + , D.fromChars "name." + , D.fromChars "One" + , D.fromChars "in" + , D.fromChars "the" + , D.dullyellow (D.fromChars (Pkg.toChars pkg)) + , D.fromChars "package," + , D.fromChars "and" + , D.fromChars "another" + , D.fromChars "defined" + , D.fromChars "locally" + , D.fromChars "in" + , D.fromChars "the" + , D.dullyellow (D.fromChars path) + , D.fromChars "file." + , D.fromChars "I" + , D.fromChars "do" + , D.fromChars "not" + , D.fromChars "have" + , D.fromChars "a" + , D.fromChars "way" + , D.fromChars "to" + , D.fromChars "choose" + , D.fromChars "between" + , D.fromChars "them." + ] + , D.reflow + "Try changing the name of the locally defined module to clear up the ambiguity?" + ] + ) + + AmbiguousLocal path1 path2 paths -> + Report.Report "AMBIGUOUS IMPORT" region [] <| + Code.toSnippet source + region + Nothing + ( D.reflow + ("You are trying to import a `" ++ name ++ "` module:") + , D.stack + [ D.reflow + "But I found multiple files in your \"source-directories\" with that name:" + , D.dullyellow <| + D.indent 4 <| + D.vcat <| + List.map D.fromChars (path1 :: path2 :: paths) + , D.reflow + "Change the module names to be distinct!" + ] + ) + + AmbiguousForeign pkg1 pkg2 pkgs -> + Report.Report "AMBIGUOUS IMPORT" region [] <| + Code.toSnippet source + region + Nothing + ( D.reflow + ("You are trying to import a `" ++ name ++ "` module:") + , D.stack + [ D.reflow + "But multiple packages in your \"dependencies\" that expose a module that name:" + , D.dullyellow <| + D.indent 4 <| + D.vcat <| + List.map (D.fromChars << Pkg.toChars) (pkg1 :: pkg2 :: pkgs) + , D.reflow + "There is no way to disambiguate in cases like this right now. Of the known name clashes, they are usually for packages with similar purposes, so the current recommendation is to pick just one of them." + , D.toSimpleNote + "It seems possible to resolve this with new syntax in imports, but that is more complicated than it sounds. Right now, our module names are tied to GitHub repos, but we may want to get rid of that dependency for a variety of reasons. That would in turn have implications for our package infrastructure, hosting costs, and possibly on how package names are specified. The particular syntax chosen seems like it would interact with all these factors in ways that are difficult to predict, potentially leading to harder problems later on. So more design work and planning is needed on these topics." + ] + ) + + +toSuggestions : ModuleName.Raw -> EverySet String ModuleName.Raw -> List ModuleName.Raw +toSuggestions name unimportedModules = + List.take 4 <| + Suggest.sort name identity (EverySet.toList compare unimportedModules) + + + +-- ENCODERS and DECODERS + + +problemEncoder : Problem -> BE.Encoder +problemEncoder problem = + case problem of + NotFound -> + BE.unsignedInt8 0 + + Ambiguous path paths pkg pkgs -> + BE.sequence + [ BE.unsignedInt8 1 + , BE.string path + , BE.list BE.string paths + , Pkg.nameEncoder pkg + , BE.list Pkg.nameEncoder pkgs + ] + + AmbiguousLocal path1 path2 paths -> + BE.sequence + [ BE.unsignedInt8 2 + , BE.string path1 + , BE.string path2 + , BE.list BE.string paths + ] + + AmbiguousForeign pkg1 pkg2 pkgs -> + BE.sequence + [ BE.unsignedInt8 3 + , Pkg.nameEncoder pkg1 + , Pkg.nameEncoder pkg2 + , BE.list Pkg.nameEncoder pkgs + ] + + +problemDecoder : BD.Decoder Problem +problemDecoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.succeed NotFound + + 1 -> + BD.map4 Ambiguous + BD.string + (BD.list BD.string) + Pkg.nameDecoder + (BD.list Pkg.nameDecoder) + + 2 -> + BD.map3 AmbiguousLocal + BD.string + BD.string + (BD.list BD.string) + + 3 -> + BD.map3 AmbiguousForeign + Pkg.nameDecoder + Pkg.nameDecoder + (BD.list Pkg.nameDecoder) + + _ -> + BD.fail + ) + + +errorEncoder : Error -> BE.Encoder +errorEncoder (Error region name unimportedModules problem) = + BE.sequence + [ A.regionEncoder region + , ModuleName.rawEncoder name + , BE.everySet compare ModuleName.rawEncoder unimportedModules + , problemEncoder problem + ] + + +errorDecoder : BD.Decoder Error +errorDecoder = + BD.map4 Error + A.regionDecoder + ModuleName.rawDecoder + (BD.everySet identity ModuleName.rawDecoder) + problemDecoder diff --git a/src/Compiler/Reporting/Error/Json.elm b/src/Compiler/Reporting/Error/Json.elm new file mode 100644 index 0000000000..a89f98605c --- /dev/null +++ b/src/Compiler/Reporting/Error/Json.elm @@ -0,0 +1,477 @@ +module Compiler.Reporting.Error.Json exposing + ( Context(..) + , FailureToReport(..) + , Reason(..) + , toReport + ) + +import Builder.Reporting.Exit.Help as Help +import Compiler.Data.NonEmptyList as NE +import Compiler.Json.Decode exposing (DecodeExpectation(..), Error(..), ParseError(..), Problem(..), StringProblem(..)) +import Compiler.Reporting.Annotation as A +import Compiler.Reporting.Doc as D +import Compiler.Reporting.Render.Code as Code +import Utils.Crash exposing (crash) +import Utils.Main as Utils + + + +-- TO REPORT + + +toReport : String -> FailureToReport x -> Error x -> Reason -> Help.Report +toReport path ftr err reason = + case err of + DecodeProblem bytes problem -> + problemToReport path ftr (Code.toSource bytes) CRoot problem reason + + ParseProblem bytes parseError -> + parseErrorToReport path (Code.toSource bytes) parseError reason + + +type Reason + = ExplicitReason String + + +because : Reason -> String -> String +because (ExplicitReason iNeedThings) problem = + iNeedThings ++ " " ++ problem + + + +-- PARSE ERROR TO REPORT + + +parseErrorToReport : String -> Code.Source -> ParseError -> Reason -> Help.Report +parseErrorToReport path source parseError reason = + let + toSnippet : String -> Int -> Int -> ( String, D.Doc ) -> Help.Report + toSnippet title row col ( problem, details ) = + let + pos : A.Position + pos = + A.Position row col + + surroundings : A.Region + surroundings = + A.Region (A.Position (max 1 (row - 2)) 1) pos + + region : A.Region + region = + A.Region pos pos + in + Help.jsonReport title (Just path) <| + Code.toSnippet source + surroundings + (Just region) + ( D.reflow (because reason problem) + , details + ) + in + case parseError of + Start row col -> + toSnippet "EXPECTING A VALUE" + row + col + ( "I was expecting to see a JSON value next:" + , D.stack + [ D.fillSep + [ D.fromChars "Try" + , D.fromChars "something" + , D.fromChars "like" + , D.dullyellow (D.fromChars "\"this\"") + , D.fromChars "or" + , D.dullyellow (D.fromChars "42") + , D.fromChars "to" + , D.fromChars "move" + , D.fromChars "on" + , D.fromChars "to" + , D.fromChars "better" + , D.fromChars "hints!" + ] + , D.toSimpleNote <| + "The JSON specification does not allow trailing commas, so you can sometimes get this error in arrays that have an extra comma at the end. In that case, remove that last comma or add another array entry after it!" + ] + ) + + ObjectField row col -> + toSnippet "EXTRA COMMA" + row + col + ( "I was partway through parsing a JSON object when I got stuck here:" + , D.stack + [ D.fillSep + [ D.fromChars "I" + , D.fromChars "saw" + , D.fromChars "a" + , D.fromChars "comma" + , D.fromChars "right" + , D.fromChars "before" + , D.fromChars "I" + , D.fromChars "got" + , D.fromChars "stuck" + , D.fromChars "here," + , D.fromChars "so" + , D.fromChars "I" + , D.fromChars "was" + , D.fromChars "expecting" + , D.fromChars "to" + , D.fromChars "see" + , D.fromChars "a" + , D.fromChars "field" + , D.fromChars "name" + , D.fromChars "like" + , D.dullyellow (D.fromChars "\"type\"") + , D.fromChars "or" + , D.dullyellow (D.fromChars "\"dependencies\"") + , D.fromChars "next." + ] + , D.reflow <| + "This error is commonly caused by trailing commas in JSON objects. Those are actually disallowed by so check the previous line for a trailing comma that may need to be deleted." + , objectNote + ] + ) + + ObjectColon row col -> + toSnippet "EXPECTING COLON" + row + col + ( "I was partway through parsing a JSON object when I got stuck here:" + , D.stack + [ D.reflow "I was expecting to see a colon next." + , objectNote + ] + ) + + ObjectEnd row col -> + toSnippet "UNFINISHED OBJECT" + row + col + ( "I was partway through parsing a JSON object when I got stuck here:" + , D.stack + [ D.reflow "I was expecting to see a comma or a closing curly brace next." + , D.reflow "Is a comma missing on the previous line? Is an array missing a closing square bracket? It is often something tricky like that!" + , objectNote + ] + ) + + ArrayEnd row col -> + toSnippet "UNFINISHED ARRAY" + row + col + ( "I was partway through parsing a JSON array when I got stuck here:" + , D.stack + [ D.reflow "I was expecting to see a comma or a closing square bracket next." + , D.reflow "Is a comma missing on the previous line? It is often something like that!" + ] + ) + + StringProblem stringProblem row col -> + case stringProblem of + BadStringEnd -> + toSnippet "ENDLESS STRING" + row + col + ( "I got to the end of the line without seeing the closing double quote:2" + , D.fillSep + [ D.fromChars "Strings" + , D.fromChars "look" + , D.fromChars "like" + , D.green (D.fromChars "\"this\"") + , D.fromChars "with" + , D.fromChars "double" + , D.fromChars "quotes" + , D.fromChars "on" + , D.fromChars "each" + , D.fromChars "end." + , D.fromChars "Is" + , D.fromChars "the" + , D.fromChars "closing" + , D.fromChars "double" + , D.fromChars "quote" + , D.fromChars "missing" + , D.fromChars "in" + , D.fromChars "your" + , D.fromChars "code?" + ] + ) + + BadStringControlChar -> + toSnippet "UNEXPECTED CONTROL CHARACTER" + row + col + ( "I ran into a control character unexpectedly:" + , D.reflow + "These are characters that represent tabs, backspaces, newlines, and a bunch of other invisible characters. They all come before 20 in the ASCII range, and they are disallowed by the JSON specificaiton. Maybe a copy/paste added one of these invisible characters to your JSON?" + ) + + BadStringEscapeChar -> + toSnippet "UNKNOWN ESCAPE" + row + col + ( "Backslashes always start escaped characters, but I do not recognize this one:" + , D.stack + [ D.reflow "Valid escape characters include:" + , D.dullyellow <| + D.indent 4 <| + D.vcat + [ D.fromChars "\\\"" + , D.fromChars "\\\\" + , D.fromChars "\\/" + , D.fromChars "\\b" + , D.fromChars "\\f" + , D.fromChars "\\n" + , D.fromChars "\\r" + , D.fromChars "\\t" + , D.fromChars "\\u003D" + ] + , D.reflow "Do you want one of those instead? Maybe you need \\\\ to escape a backslash?" + ] + ) + + BadStringEscapeHex -> + toSnippet "BAD HEX ESCAPE" + row + col + ( "This is not a valid hex escape:" + , D.fillSep + [ D.fromChars "Valid" + , D.fromChars "hex" + , D.fromChars "escapes" + , D.fromChars "in" + , D.fromChars "JSON" + , D.fromChars "are" + , D.fromChars "between" + , D.green (D.fromChars "\\u0000") + , D.fromChars "and" + , D.green (D.fromChars "\\uFFFF") + , D.fromChars "and" + , D.fromChars "always" + , D.fromChars "have" + , D.fromChars "exactly" + , D.fromChars "four" + , D.fromChars "digits." + ] + ) + + NoLeadingZeros row col -> + toSnippet "BAD NUMBER" + row + col + ( "Numbers cannot start with zeros like this:" + , D.reflow "Try deleting the leading zeros?" + ) + + NoFloats row col -> + toSnippet "UNEXPECTED NUMBER" + row + col + ( "I got stuck while trying to parse this number:" + , D.reflow + "I do not accept floating point numbers like 3.1415 right now. That kind of JSON value is not needed for any of the uses that Elm has for now." + ) + + BadEnd row col -> + toSnippet "JSON PROBLEM" + row + col + ( "I was partway through parsing some JSON when I got stuck here:" + , D.reflow + "I am not really sure what is wrong. This sometimes means there is extra stuff after a valid JSON value?" + ) + + +objectNote : D.Doc +objectNote = + D.stack + [ D.toSimpleNote "Here is an example of a valid JSON object for reference:" + , D.vcat + [ D.indent 4 (D.fromChars "{") + , D.indent 6 + (D.dullyellow (D.fromChars "\"name\"") + |> D.a (D.fromChars ": ") + |> D.a (D.dullyellow (D.fromChars "\"Tom\"")) + |> D.a (D.fromChars ",") + ) + , D.indent 6 + (D.dullyellow (D.fromChars "\"age\"") + |> D.a (D.fromChars ": ") + |> D.a (D.dullyellow (D.fromChars "42")) + ) + , D.indent 4 (D.fromChars "}") + ] + , D.reflow + "Notice that (1) the field names are in double quotes and (2) there is no trailing comma after the last entry. Both are strict requirements in JSON!" + ] + + + +-- PROBLEM TO REPORT + + +type Context + = CRoot + | CField String Context + | CIndex Int Context + + +problemToReport : String -> FailureToReport x -> Code.Source -> Context -> Problem x -> Reason -> Help.Report +problemToReport path (FailureToReport ftr) source context problem reason = + case problem of + Field field prob -> + problemToReport path (FailureToReport ftr) source (CField field context) prob reason + + Index index prob -> + problemToReport path (FailureToReport ftr) source (CIndex index context) prob reason + + OneOf p ps -> + -- NOTE: only displays the deepest problem. This works well for the kind + -- of JSON used by Elm, but probably would not work well in general. + let + (NE.Nonempty prob _) = + NE.sortBy (negate << getMaxDepth) (NE.Nonempty p ps) + in + problemToReport path (FailureToReport ftr) source context prob reason + + Failure region x -> + ftr path source context region x + + Expecting region expectation -> + expectationToReport path source context region expectation reason + + +getMaxDepth : Problem x -> Int +getMaxDepth problem = + case problem of + Field _ prob -> + 1 + getMaxDepth prob + + Index _ prob -> + 1 + getMaxDepth prob + + OneOf p ps -> + -- NOTE: only displays the deepest problem. This works well for the kind + -- of JSON used by Elm, but probably would not work well in general. + Utils.listMaximum compare (getMaxDepth p :: List.map getMaxDepth ps) + + Failure _ _ -> + 0 + + Expecting _ _ -> + 0 + + +type FailureToReport x + = FailureToReport (String -> Code.Source -> Context -> A.Region -> x -> Help.Report) + + +expectationToReport : String -> Code.Source -> Context -> A.Region -> DecodeExpectation -> Reason -> Help.Report +expectationToReport path source context (A.Region start end) expectation reason = + let + (A.Position sr _) = + start + + (A.Position er _) = + end + + region : A.Region + region = + if sr == er then + crash "region" + + else + A.Region start start + + introduction : String + introduction = + case context of + CRoot -> + "I ran into some trouble here:" + + CField field _ -> + "I ran into trouble with the value of the \"" ++ field ++ "\" field:" + + CIndex index (CField field _) -> + "When looking at the \"" + ++ field + ++ "\" field, I ran into trouble with the " + ++ D.intToOrdinal index + ++ " entry:" + + CIndex index _ -> + "I ran into trouble with the " ++ D.intToOrdinal index ++ " index of this array:" + + toSnippet : String -> List D.Doc -> Help.Report + toSnippet title aThing = + Help.jsonReport title (Just path) <| + Code.toSnippet source + region + Nothing + ( D.reflow (because reason introduction) + , D.fillSep <| + [ D.fromChars "I" + , D.fromChars "was" + , D.fromChars "expecting" + , D.fromChars "to" + , D.fromChars "run" + , D.fromChars "into" + ] + ++ aThing + ) + in + case expectation of + TObject -> + toSnippet "EXPECTING OBJECT" + [ D.fromChars "an" + , D.green (D.fromChars "OBJECT") + |> D.a (D.fromChars ".") + ] + + TArray -> + toSnippet "EXPECTING ARRAY" + [ D.fromChars "an" + , D.green (D.fromChars "ARRAY") + |> D.a (D.fromChars ".") + ] + + TString -> + toSnippet "EXPECTING STRING" + [ D.fromChars "a" + , D.green (D.fromChars "STRING") + |> D.a (D.fromChars ".") + ] + + TInt -> + toSnippet "EXPECTING INT" + [ D.fromChars "an" + , D.green (D.fromChars "INT") + |> D.a (D.fromChars ".") + ] + + TObjectWith field -> + toSnippet "MISSING FIELD" + [ D.fromChars "an" + , D.green (D.fromChars "OBJECT") + , D.fromChars "with" + , D.fromChars "a" + , D.green (D.fromChars ("\"" ++ field ++ "\"")) + , D.fromChars "field." + ] + + TArrayPair len -> + toSnippet "EXPECTING PAIR" + [ D.fromChars "an" + , D.green (D.fromChars "ARRAY") + , D.fromChars "with" + , D.green (D.fromChars "TWO") + , D.fromChars "entries." + , D.fromChars "This" + , D.fromChars "array" + , D.fromChars "has" + , D.fromInt len + , if len == 1 then + D.fromChars "element." + + else + D.fromChars "elements." + ] diff --git a/src/Compiler/Reporting/Error/Main.elm b/src/Compiler/Reporting/Error/Main.elm new file mode 100644 index 0000000000..fbc08f9584 --- /dev/null +++ b/src/Compiler/Reporting/Error/Main.elm @@ -0,0 +1,153 @@ +module Compiler.Reporting.Error.Main exposing + ( Error(..) + , errorDecoder + , errorEncoder + , toReport + ) + +import Compiler.AST.Canonical as Can +import Compiler.Data.Name exposing (Name) +import Compiler.Reporting.Annotation as A +import Compiler.Reporting.Doc as D +import Compiler.Reporting.Error.Canonicalize as E +import Compiler.Reporting.Render.Code as Code +import Compiler.Reporting.Render.Type as RT +import Compiler.Reporting.Render.Type.Localizer as L +import Compiler.Reporting.Report as Report +import Utils.Bytes.Decode as BD +import Utils.Bytes.Encode as BE + + + +-- ERROR + + +type Error + = BadType A.Region Can.Type + | BadCycle A.Region Name (List Name) + | BadFlags A.Region Can.Type E.InvalidPayload + + + +-- TO REPORT + + +toReport : L.Localizer -> Code.Source -> Error -> Report.Report +toReport localizer source err = + case err of + BadType region tipe -> + Report.Report "BAD MAIN TYPE" region [] <| + Code.toSnippet source region Nothing <| + ( D.fromChars "I cannot handle this type of `main` value:" + , D.stack + [ D.fromChars "The type of `main` value I am seeing is:" + , D.indent 4 <| D.dullyellow <| RT.canToDoc localizer RT.None tipe + , D.reflow "I only know how to handle Html, Svg, and Programs though. Modify `main` to be one of those types of values!" + ] + ) + + BadCycle region name names -> + Report.Report "BAD MAIN" region [] <| + Code.toSnippet source region Nothing <| + ( D.fromChars "A `main` definition cannot be defined in terms of itself." + , D.stack + [ D.reflow "It should be a boring value with no recursion. But instead it is involved in this cycle of definitions:" + , D.cycle 4 name names + ] + ) + + BadFlags region _ invalidPayload -> + let + formatDetails : ( String, D.Doc ) -> Report.Report + formatDetails ( aBadKindOfThing, butThatIsNoGood ) = + Report.Report "BAD FLAGS" region [] <| + Code.toSnippet source region Nothing <| + ( D.reflow ("Your `main` program wants " ++ aBadKindOfThing ++ " from JavaScript.") + , butThatIsNoGood + ) + in + formatDetails <| + case invalidPayload of + E.ExtendedRecord -> + ( "an extended record" + , D.reflow "But the exact shape of the record must be known at compile time. No type variables!" + ) + + E.Function -> + ( "a function" + , D.reflow "But if I allowed functions from JS, it would be possible to sneak side-effects and runtime exceptions into Elm!" + ) + + E.TypeVariable name -> + ( "an unspecified type" + , D.reflow ("But type variables like `" ++ name ++ "` cannot be given as flags. I need to know exactly what type of data I am getting, so I can guarantee that unexpected data cannot sneak in and crash the Elm program.") + ) + + E.UnsupportedType name -> + ( "a `" ++ name ++ "` value" + , D.stack + [ D.reflow "I cannot handle that. The types that CAN be in flags include:" + , D.indent 4 <| + D.reflow "Ints, Floats, Bools, Strings, Maybes, Lists, Arrays, tuples, records, and JSON values." + , D.reflow "Since JSON values can flow through, you can use JSON encoders and decoders to allow other types through as well. More advanced users often just do everything with encoders and decoders for more control and better errors." + ] + ) + + + +-- ENCODERS and DECODERS + + +errorEncoder : Error -> BE.Encoder +errorEncoder error = + case error of + BadType region tipe -> + BE.sequence + [ BE.unsignedInt8 0 + , A.regionEncoder region + , Can.typeEncoder tipe + ] + + BadCycle region name names -> + BE.sequence + [ BE.unsignedInt8 1 + , A.regionEncoder region + , BE.string name + , BE.list BE.string names + ] + + BadFlags region subType invalidPayload -> + BE.sequence + [ BE.unsignedInt8 2 + , A.regionEncoder region + , Can.typeEncoder subType + , E.invalidPayloadEncoder invalidPayload + ] + + +errorDecoder : BD.Decoder Error +errorDecoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.map2 BadType + A.regionDecoder + Can.typeDecoder + + 1 -> + BD.map3 BadCycle + A.regionDecoder + BD.string + (BD.list BD.string) + + 2 -> + BD.map3 BadFlags + A.regionDecoder + Can.typeDecoder + E.invalidPayloadDecoder + + _ -> + BD.fail + ) diff --git a/src/Compiler/Reporting/Error/Pattern.elm b/src/Compiler/Reporting/Error/Pattern.elm new file mode 100644 index 0000000000..554d0b0831 --- /dev/null +++ b/src/Compiler/Reporting/Error/Pattern.elm @@ -0,0 +1,204 @@ +module Compiler.Reporting.Error.Pattern exposing (toReport) + +import Compiler.Nitpick.PatternMatches as P +import Compiler.Reporting.Doc as D +import Compiler.Reporting.Render.Code as Code +import Compiler.Reporting.Report as Report + + + +-- TO REPORT + + +toReport : Code.Source -> P.Error -> Report.Report +toReport source err = + case err of + P.Redundant caseRegion patternRegion index -> + Report.Report "REDUNDANT PATTERN" patternRegion [] <| + Code.toSnippet source + caseRegion + (Just patternRegion) + ( D.reflow <| + "The " + ++ D.intToOrdinal index + ++ " pattern is redundant:" + , D.reflow <| + "Any value with this shape will be handled by a previous pattern, so it should be removed." + ) + + P.Incomplete region context unhandled -> + case context of + P.BadArg -> + Report.Report "UNSAFE PATTERN" region [] <| + Code.toSnippet source + region + Nothing + ( D.fromChars "This pattern does not cover all possibilities:" + , D.stack + [ D.fromChars "Other possibilities include:" + , unhandledPatternsToDocBlock unhandled + , D.reflow <| + "I would have to crash if I saw one of those! So rather than pattern matching in function arguments, put a `case` in the function body to account for all possibilities." + ] + ) + + P.BadDestruct -> + Report.Report "UNSAFE PATTERN" region [] <| + Code.toSnippet source + region + Nothing + ( D.fromChars "This pattern does not cover all possible values:" + , D.stack + [ D.fromChars "Other possibilities include:" + , unhandledPatternsToDocBlock unhandled + , D.reflow <| + "I would have to crash if I saw one of those! You can use `let` to deconstruct values only if there is ONE possibility. Switch to a `case` expression to account for all possibilities." + , D.toSimpleHint <| + "Are you calling a function that definitely returns values with a very specific shape? Try making the return type of that function more specific!" + ] + ) + + P.BadCase -> + Report.Report "MISSING PATTERNS" region [] <| + Code.toSnippet source + region + Nothing + ( D.fromChars "This `case` does not have branches for all possibilities:" + , D.stack + [ D.fromChars "Missing possibilities include:" + , unhandledPatternsToDocBlock unhandled + , D.reflow <| + "I would have to crash if I saw one of those. Add branches for them!" + , D.link "Hint" + "If you want to write the code for each branch later, use `Debug.todo` as a placeholder. Read" + "missing-patterns" + "for more guidance on this workflow." + ] + ) + + + +-- PATTERN TO DOC + + +unhandledPatternsToDocBlock : List P.Pattern -> D.Doc +unhandledPatternsToDocBlock unhandledPatterns = + D.indent 4 <| + D.dullyellow <| + D.vcat <| + List.map (patternToDoc Unambiguous) unhandledPatterns + + +type Context + = Arg + | Head + | Unambiguous + + +patternToDoc : Context -> P.Pattern -> D.Doc +patternToDoc context pattern = + case delist pattern [] of + NonList P.Anything -> + D.fromChars "_" + + NonList (P.Literal literal) -> + case literal of + P.Chr chr -> + D.fromChars ("'" ++ chr ++ "'") + + P.Str str -> + D.fromChars ("\"" ++ str ++ "\"") + + P.Int int -> + D.fromChars (String.fromInt int) + + NonList (P.Ctor _ "#0" []) -> + D.fromChars "()" + + NonList (P.Ctor _ "#2" [ a, b ]) -> + D.fromChars "( " + |> D.a (patternToDoc Unambiguous a) + |> D.a (D.fromChars ", ") + |> D.a (patternToDoc Unambiguous b) + |> D.a (D.fromChars " )") + + NonList (P.Ctor _ "#3" [ a, b, c ]) -> + D.fromChars "( " + |> D.a (patternToDoc Unambiguous a) + |> D.a (D.fromChars ", ") + |> D.a (patternToDoc Unambiguous b) + |> D.a (D.fromChars ", ") + |> D.a (patternToDoc Unambiguous c) + |> D.a (D.fromChars " )") + + NonList (P.Ctor _ name args) -> + let + ctorDoc : D.Doc + ctorDoc = + D.hsep (D.fromChars name :: List.map (patternToDoc Arg) args) + in + if context == Arg && List.length args > 0 then + D.fromChars "(" + |> D.a ctorDoc + |> D.a (D.fromChars ")") + + else + ctorDoc + + FiniteList [] -> + D.fromChars "[]" + + FiniteList entries -> + let + entryDocs : List D.Doc + entryDocs = + List.map (patternToDoc Unambiguous) entries + in + D.fromChars "[" + |> D.a (D.hcat (List.intersperse (D.fromChars ",") entryDocs)) + |> D.a (D.fromChars "]") + + Conses conses finalPattern -> + let + consDoc : D.Doc + consDoc = + List.foldr + (\hd tl -> + patternToDoc Head hd + |> D.a (D.fromChars " :: ") + |> D.a tl + ) + (patternToDoc Unambiguous finalPattern) + conses + in + if context == Unambiguous then + consDoc + + else + D.fromChars "(" + |> D.a consDoc + |> D.a (D.fromChars ")") + + +type Structure + = FiniteList (List P.Pattern) + | Conses (List P.Pattern) P.Pattern + | NonList P.Pattern + + +delist : P.Pattern -> List P.Pattern -> Structure +delist pattern revEntries = + case pattern of + P.Ctor _ "[]" [] -> + FiniteList revEntries + + P.Ctor _ "::" [ hd, tl ] -> + delist tl (hd :: revEntries) + + _ -> + case revEntries of + [] -> + NonList pattern + + _ -> + Conses (List.reverse revEntries) pattern diff --git a/src/Compiler/Reporting/Error/Syntax.elm b/src/Compiler/Reporting/Error/Syntax.elm new file mode 100644 index 0000000000..322ccae5ea --- /dev/null +++ b/src/Compiler/Reporting/Error/Syntax.elm @@ -0,0 +1,11715 @@ +module Compiler.Reporting.Error.Syntax exposing + ( Case(..) + , Char(..) + , CustomType(..) + , Decl(..) + , DeclDef(..) + , DeclType(..) + , Def(..) + , Destruct(..) + , Error(..) + , Escape(..) + , Exposing(..) + , Expr(..) + , Func(..) + , If(..) + , Let(..) + , List_(..) + , Module(..) + , Number(..) + , PList(..) + , PRecord(..) + , PTuple(..) + , Pattern(..) + , Port(..) + , Record(..) + , Space(..) + , String_(..) + , TRecord(..) + , TTuple(..) + , Tuple(..) + , Type(..) + , TypeAlias(..) + , errorDecoder + , errorEncoder + , spaceDecoder + , spaceEncoder + , toReport + , toSpaceReport + ) + +import Compiler.Data.Name exposing (Name) +import Compiler.Elm.ModuleName as ModuleName +import Compiler.Parse.Primitives exposing (Col, Row) +import Compiler.Parse.Symbol as Symbol exposing (BadOperator(..)) +import Compiler.Parse.SyntaxVersion as SV exposing (SyntaxVersion) +import Compiler.Reporting.Annotation as A +import Compiler.Reporting.Doc as D +import Compiler.Reporting.Render.Code as Code +import Compiler.Reporting.Report as Report +import Hex +import Utils.Bytes.Decode as BD +import Utils.Bytes.Encode as BE + + + +-- ALL SYNTAX ERRORS + + +type Error + = ModuleNameUnspecified ModuleName.Raw + | ModuleNameMismatch ModuleName.Raw (A.Located ModuleName.Raw) + | UnexpectedPort A.Region + | NoPorts A.Region + | NoPortsInPackage (A.Located Name) + | NoPortModulesInPackage A.Region + | NoEffectsOutsideKernel A.Region + | ParseError Module + + +type Module + = ModuleSpace Space Row Col + | ModuleBadEnd Row Col + -- + | ModuleProblem Row Col + | ModuleName Row Col + | ModuleExposing Exposing Row Col + -- + | PortModuleProblem Row Col + | PortModuleName Row Col + | PortModuleExposing Exposing Row Col + -- + | Effect Row Col + -- + | FreshLine Row Col + -- + | ImportStart Row Col + | ImportName Row Col + | ImportAs Row Col + | ImportAlias Row Col + | ImportExposing Row Col + | ImportExposingList Exposing Row Col + | ImportEnd Row Col -- different based on col=1 or if greater + -- + | ImportIndentName Row Col + | ImportIndentAlias Row Col + | ImportIndentExposingList Row Col + -- + | Infix Row Col + -- + | Declarations Decl Row Col + + +type Exposing + = ExposingSpace Space Row Col + | ExposingStart Row Col + | ExposingValue Row Col + | ExposingOperator Row Col + | ExposingOperatorReserved BadOperator Row Col + | ExposingOperatorRightParen Row Col + | ExposingTypePrivacy Row Col + | ExposingEnd Row Col + -- + | ExposingIndentEnd Row Col + | ExposingIndentValue Row Col + + + +-- DECLARATIONS + + +type Decl + = DeclStart Row Col + | DeclSpace Space Row Col + -- + | Port Port Row Col + | DeclType DeclType Row Col + | DeclDef Name DeclDef Row Col + -- + | DeclFreshLineAfterDocComment Row Col + + +type DeclDef + = DeclDefSpace Space Row Col + | DeclDefEquals Row Col + | DeclDefType Type Row Col + | DeclDefArg Pattern Row Col + | DeclDefBody Expr Row Col + | DeclDefNameRepeat Row Col + | DeclDefNameMatch Name Row Col + -- + | DeclDefIndentType Row Col + | DeclDefIndentEquals Row Col + | DeclDefIndentBody Row Col + + +type Port + = PortSpace Space Row Col + | PortName Row Col + | PortColon Row Col + | PortType Type Row Col + | PortIndentName Row Col + | PortIndentColon Row Col + | PortIndentType Row Col + + + +-- TYPE DECLARATIONS + + +type DeclType + = DT_Space Space Row Col + | DT_Name Row Col + | DT_Alias TypeAlias Row Col + | DT_Union CustomType Row Col + -- + | DT_IndentName Row Col + + +type TypeAlias + = AliasSpace Space Row Col + | AliasName Row Col + | AliasEquals Row Col + | AliasBody Type Row Col + -- + | AliasIndentEquals Row Col + | AliasIndentBody Row Col + + +type CustomType + = CT_Space Space Row Col + | CT_Name Row Col + | CT_Equals Row Col + | CT_Bar Row Col + | CT_Variant Row Col + | CT_VariantArg Type Row Col + -- + | CT_IndentEquals Row Col + | CT_IndentBar Row Col + | CT_IndentAfterBar Row Col + | CT_IndentAfterEquals Row Col + + + +-- EXPRESSIONS + + +type Expr + = Let Let Row Col + | Case Case Row Col + | If If Row Col + | List List_ Row Col + | Record Record Row Col + | Tuple Tuple Row Col + | Func Func Row Col + -- + | Dot Row Col + | Access Row Col + | OperatorRight Name Row Col + | OperatorReserved BadOperator Row Col + -- + | Start Row Col + | Char Char Row Col + | String_ String_ Row Col + | Number Number Row Col + | Space Space Row Col + | EndlessShader Row Col + | ShaderProblem String Row Col + | IndentOperatorRight Name Row Col + + +type Record + = RecordOpen Row Col + | RecordEnd Row Col + | RecordField Row Col + | RecordEquals Row Col + | RecordExpr Expr Row Col + | RecordSpace Space Row Col + -- + | RecordIndentOpen Row Col + | RecordIndentEnd Row Col + | RecordIndentField Row Col + | RecordIndentEquals Row Col + | RecordIndentExpr Row Col + + +type Tuple + = TupleExpr Expr Row Col + | TupleSpace Space Row Col + | TupleEnd Row Col + | TupleOperatorClose Row Col + | TupleOperatorReserved BadOperator Row Col + -- + | TupleIndentExpr1 Row Col + | TupleIndentExprN Row Col + | TupleIndentEnd Row Col + + +type List_ + = ListSpace Space Row Col + | ListOpen Row Col + | ListExpr Expr Row Col + | ListEnd Row Col + -- + | ListIndentOpen Row Col + | ListIndentEnd Row Col + | ListIndentExpr Row Col + + +type Func + = FuncSpace Space Row Col + | FuncArg Pattern Row Col + | FuncBody Expr Row Col + | FuncArrow Row Col + -- + | FuncIndentArg Row Col + | FuncIndentArrow Row Col + | FuncIndentBody Row Col + + +type Case + = CaseSpace Space Row Col + | CaseOf Row Col + | CasePattern Pattern Row Col + | CaseArrow Row Col + | CaseExpr Expr Row Col + | CaseBranch Expr Row Col + -- + | CaseIndentOf Row Col + | CaseIndentExpr Row Col + | CaseIndentPattern Row Col + | CaseIndentArrow Row Col + | CaseIndentBranch Row Col + | CasePatternAlignment Int Row Col + + +type If + = IfSpace Space Row Col + | IfThen Row Col + | IfElse Row Col + | IfElseBranchStart Row Col + -- + | IfCondition Expr Row Col + | IfThenBranch Expr Row Col + | IfElseBranch Expr Row Col + -- + | IfIndentCondition Row Col + | IfIndentThen Row Col + | IfIndentThenBranch Row Col + | IfIndentElseBranch Row Col + | IfIndentElse Row Col + + +type Let + = LetSpace Space Row Col + | LetIn Row Col + | LetDefAlignment Int Row Col + | LetDefName Row Col + | LetDef Name Def Row Col + | LetDestruct Destruct Row Col + | LetBody Expr Row Col + | LetIndentDef Row Col + | LetIndentIn Row Col + | LetIndentBody Row Col + + +type Def + = DefSpace Space Row Col + | DefType Type Row Col + | DefNameRepeat Row Col + | DefNameMatch Name Row Col + | DefArg Pattern Row Col + | DefEquals Row Col + | DefBody Expr Row Col + | DefIndentEquals Row Col + | DefIndentType Row Col + | DefIndentBody Row Col + | DefAlignment Int Row Col + + +type Destruct + = DestructSpace Space Row Col + | DestructPattern Pattern Row Col + | DestructEquals Row Col + | DestructBody Expr Row Col + | DestructIndentEquals Row Col + | DestructIndentBody Row Col + + + +-- PATTERNS + + +type Pattern + = PRecord PRecord Row Col + | PTuple PTuple Row Col + | PList PList Row Col + -- + | PStart Row Col + | PChar Char Row Col + | PString String_ Row Col + | PNumber Number Row Col + | PFloat Int Row Col + | PAlias Row Col + | PWildcardNotVar Name Int Row Col + | PWildcardReservedWord Name Int Row Col + | PSpace Space Row Col + -- + | PIndentStart Row Col + | PIndentAlias Row Col + + +type PRecord + = PRecordOpen Row Col + | PRecordEnd Row Col + | PRecordField Row Col + | PRecordSpace Space Row Col + -- + | PRecordIndentOpen Row Col + | PRecordIndentEnd Row Col + | PRecordIndentField Row Col + + +type PTuple + = PTupleOpen Row Col + | PTupleEnd Row Col + | PTupleExpr Pattern Row Col + | PTupleSpace Space Row Col + -- + | PTupleIndentEnd Row Col + | PTupleIndentExpr1 Row Col + | PTupleIndentExprN Row Col + + +type PList + = PListOpen Row Col + | PListEnd Row Col + | PListExpr Pattern Row Col + | PListSpace Space Row Col + -- + | PListIndentOpen Row Col + | PListIndentEnd Row Col + | PListIndentExpr Row Col + + + +-- TYPES + + +type Type + = TRecord TRecord Row Col + | TTuple TTuple Row Col + -- + | TStart Row Col + | TSpace Space Row Col + -- + | TIndentStart Row Col + + +type TRecord + = TRecordOpen Row Col + | TRecordEnd Row Col + -- + | TRecordField Row Col + | TRecordColon Row Col + | TRecordType Type Row Col + -- + | TRecordSpace Space Row Col + -- + | TRecordIndentOpen Row Col + | TRecordIndentField Row Col + | TRecordIndentColon Row Col + | TRecordIndentType Row Col + | TRecordIndentEnd Row Col + + +type TTuple + = TTupleOpen Row Col + | TTupleEnd Row Col + | TTupleType Type Row Col + | TTupleSpace Space Row Col + -- + | TTupleIndentType1 Row Col + | TTupleIndentTypeN Row Col + | TTupleIndentEnd Row Col + + + +-- LITERALS + + +type Char + = CharEndless + | CharEscape Escape + | CharNotString Int + + +type String_ + = StringEndless_Single + | StringEndless_Multi + | StringEscape Escape + + +type Escape + = EscapeUnknown + | BadUnicodeFormat Int + | BadUnicodeCode Int + | BadUnicodeLength Int Int Int + + +type Number + = NumberEnd + | NumberDot Int + | NumberHexDigit + | NumberBinDigit + | NumberNoLeadingZero + | NumberNoLeadingOrTrailingUnderscores + | NumberNoConsecutiveUnderscores + | NumberNoUnderscoresAdjacentToDecimalOrExponent + | NumberNoUnderscoresAdjacentToHexadecimalPreFix + | NumberNoUnderscoresAdjacentToBinaryPreFix + + + +-- MISC + + +type Space + = HasTab + | EndlessMultiComment + + + +-- TO REPORT + + +toReport : SyntaxVersion -> Code.Source -> Error -> Report.Report +toReport syntaxVersion source err = + case err of + ModuleNameUnspecified name -> + let + region : A.Region + region = + toRegion 1 1 + in + Report.Report "MODULE NAME MISSING" region [] <| + D.stack + [ D.reflow "I need the module name to be declared at the top of this file, like this:" + , D.indent 4 <| + D.fillSep <| + [ D.cyan (D.fromChars "module") + , D.fromName name + , D.cyan (D.fromChars "exposing") + , D.fromChars "(..)" + ] + , D.reflow <| + "Try adding that as the first line of your file!" + , D.toSimpleNote <| + "It is best to replace (..) with an explicit list of types and functions you want to expose. When you know a value is only used within this module, you can refactor without worrying about uses elsewhere. Limiting exposed values can also speed up compilation because I can skip a bunch of work if I see that the exposed API has not changed." + ] + + ModuleNameMismatch expectedName (A.At region actualName) -> + Report.Report "MODULE NAME MISMATCH" region [ expectedName ] <| + Code.toSnippet source region Nothing <| + ( D.fromChars "It looks like this module name is out of sync:" + , D.stack + [ D.reflow <| + "I need it to match the file path, so I was expecting to see `" + ++ expectedName + ++ "` here. Make the following change, and you should be all set!" + , D.indent 4 <| + (D.dullyellow (D.fromName actualName) + |> D.a (D.fromChars " -> ") + |> D.a (D.green (D.fromName expectedName)) + ) + , D.toSimpleNote <| + "I require that module names correspond to file paths. This makes it much easier to explore unfamiliar codebases! So if you want to keep the current module name, try renaming the file instead." + ] + ) + + UnexpectedPort region -> + Report.Report "UNEXPECTED PORTS" region [] <| + Code.toSnippet source region Nothing <| + ( D.reflow <| + "You are declaring ports in a normal module." + , D.stack + [ D.fillSep + [ D.fromChars "Switch" + , D.fromChars "this" + , D.fromChars "to" + , D.fromChars "say" + , D.cyan (D.fromChars "port module") + , D.fromChars "instead," + , D.fromChars "marking" + , D.fromChars "that" + , D.fromChars "this" + , D.fromChars "module" + , D.fromChars "contains" + , D.fromChars "port" + , D.fromChars "declarations." + ] + , D.link "Note" + "Ports are not a traditional FFI for calling JS functions directly. They need a different mindset! Read" + "ports" + "to learn the syntax and how to use it effectively." + ] + ) + + NoPorts region -> + Report.Report "NO PORTS" region [] <| + Code.toSnippet source region Nothing <| + ( D.reflow <| + "This module does not declare any ports, but it says it will:" + , D.fillSep + [ D.fromChars "Switch" + , D.fromChars "this" + , D.fromChars "to" + , D.cyan (D.fromChars "module") + , D.fromChars "and" + , D.fromChars "you" + , D.fromChars "should" + , D.fromChars "be" + , D.fromChars "all" + , D.fromChars "set!" + ] + ) + + NoPortsInPackage (A.At region _) -> + Report.Report "PACKAGES CANNOT HAVE PORTS" region [] <| + Code.toSnippet source region Nothing <| + ( D.reflow <| + "Packages cannot declare any ports, so I am getting stuck here:" + , D.stack + [ D.reflow <| + "Remove this port declaration." + , noteForPortsInPackage + ] + ) + + NoPortModulesInPackage region -> + Report.Report "PACKAGES CANNOT HAVE PORTS" region [] <| + Code.toSnippet source region Nothing <| + ( D.reflow <| + "Packages cannot declare any ports, so I am getting stuck here:" + , D.stack + [ D.fillSep <| + [ D.fromChars "Remove" + , D.fromChars "the" + , D.cyan (D.fromChars "port") + , D.fromChars "keyword" + , D.fromChars "and" + , D.fromChars "I" + , D.fromChars "should" + , D.fromChars "be" + , D.fromChars "able" + , D.fromChars "to" + , D.fromChars "continue." + ] + , noteForPortsInPackage + ] + ) + + NoEffectsOutsideKernel region -> + Report.Report "INVALID EFFECT MODULE" region [] <| + Code.toSnippet source region Nothing <| + ( D.reflow <| + "It is not possible to declare an `effect module` outside the @elm organization, so I am getting stuck here:" + , D.stack + [ D.reflow <| + "Switch to a normal module declaration." + , D.toSimpleNote <| + "Effect modules are designed to allow certain core functionality to be defined separately from the compiler. So the @elm organization has access to this so that certain changes, extensions, and fixes can be introduced without needing to release new Elm binaries. For example, we want to make it possible to test effects, but this may require changes to the design of effect modules. By only having them defined in the @elm organization, that kind of design work can proceed much more smoothly." + ] + ) + + ParseError modul -> + toParseErrorReport syntaxVersion source modul + + +noteForPortsInPackage : D.Doc +noteForPortsInPackage = + D.stack + [ D.toSimpleNote <| + "One of the major goals of the package ecosystem is to be completely written in Elm. This means when you install an Elm package, you can be sure you are safe from security issues on install and that you are not going to get any runtime exceptions coming from your new dependency. This design also sets the ecosystem up to target other platforms more easily (like mobile phones, WebAssembly, etc.) since no community code explicitly depends on JavaScript even existing." + , D.reflow <| + "Given that overall goal, allowing ports in packages would lead to some pretty surprising behavior. If ports were allowed in packages, you could install a package but not realize that it brings in an indirect dependency that defines a port. Now you have a program that does not work and the fix is to realize that some JavaScript needs to be added for a dependency you did not even know about. That would be extremely frustrating! \"So why not allow the package author to include the necessary JS code as well?\" Now we are back in conflict with our overall goal to keep all community packages free from runtime exceptions." + ] + + +toParseErrorReport : SyntaxVersion -> Code.Source -> Module -> Report.Report +toParseErrorReport syntaxVersion source modul = + case modul of + ModuleSpace space row col -> + toSpaceReport source space row col + + ModuleBadEnd row col -> + if col == 1 then + toDeclStartReport source row col + + else + toWeirdEndReport source row col + + ModuleProblem row col -> + let + region : A.Region + region = + toRegion row col + in + Report.Report "UNFINISHED MODULE DECLARATION" region [] <| + Code.toSnippet source region Nothing <| + ( D.reflow <| + "I am parsing an `module` declaration, but I got stuck here:" + , D.stack + [ D.reflow <| + "Here are some examples of valid `module` declarations:" + , D.indent 4 <| + D.vcat <| + [ D.fillSep + [ D.cyan (D.fromChars "module") + , D.fromChars "Main" + , D.cyan (D.fromChars "exposing") + , D.fromChars "(..)" + ] + , D.fillSep + [ D.cyan (D.fromChars "module") + , D.fromChars "Dict" + , D.cyan (D.fromChars "exposing") + , D.fromChars "(Dict, empty, get)" + ] + ] + , D.reflow <| + "I generally recommend using an explicit exposing list. I can skip compiling a bunch of files when the public interface of a module stays the same, so exposing fewer values can help improve compile times!" + ] + ) + + ModuleName row col -> + let + region : A.Region + region = + toRegion row col + in + Report.Report "EXPECTING MODULE NAME" region [] <| + Code.toSnippet source region Nothing <| + ( D.reflow <| + "I was parsing an `module` declaration until I got stuck here:" + , D.stack + [ D.reflow <| + "I was expecting to see the module name next, like in these examples:" + , D.indent 4 <| + D.vcat <| + [ D.fillSep + [ D.cyan (D.fromChars "module") + , D.fromChars "Dict" + , D.cyan (D.fromChars "exposing") + , D.fromChars "(..)" + ] + , D.fillSep + [ D.cyan (D.fromChars "module") + , D.fromChars "Maybe" + , D.cyan (D.fromChars "exposing") + , D.fromChars "(..)" + ] + , D.fillSep + [ D.cyan (D.fromChars "module") + , D.fromChars "Html.Attributes" + , D.cyan (D.fromChars "exposing") + , D.fromChars "(..)" + ] + , D.fillSep + [ D.cyan (D.fromChars "module") + , D.fromChars "Json.Decode" + , D.cyan (D.fromChars "exposing") + , D.fromChars "(..)" + ] + ] + , D.reflow <| + "Notice that the module names all start with capital letters. That is required!" + ] + ) + + ModuleExposing exposing_ row col -> + toExposingReport source exposing_ row col + + PortModuleProblem row col -> + let + region : A.Region + region = + toRegion row col + in + Report.Report "UNFINISHED PORT MODULE DECLARATION" region [] <| + Code.toSnippet source region Nothing <| + ( D.reflow <| + "I am parsing an `port module` declaration, but I got stuck here:" + , D.stack + [ D.reflow <| + "Here are some examples of valid `port module` declarations:" + , D.indent 4 <| + D.vcat <| + [ D.fillSep + [ D.cyan (D.fromChars "port") + , D.cyan (D.fromChars "module") + , D.fromChars "WebSockets" + , D.cyan (D.fromChars "exposing") + , D.fromChars "(send, listen, keepAlive)" + ] + , D.fillSep + [ D.cyan (D.fromChars "port") + , D.cyan (D.fromChars "module") + , D.fromChars "Maps" + , D.cyan (D.fromChars "exposing") + , D.fromChars "(Location, goto)" + ] + ] + , D.link "Note" "Read" "ports" "for more help." + ] + ) + + PortModuleName row col -> + let + region : A.Region + region = + toRegion row col + in + Report.Report "EXPECTING MODULE NAME" region [] <| + Code.toSnippet source region Nothing <| + ( D.reflow <| + "I was parsing an `module` declaration until I got stuck here:" + , D.stack + [ D.reflow <| + "I was expecting to see the module name next, like in these examples:" + , D.indent 4 <| + D.vcat <| + [ D.fillSep + [ D.cyan (D.fromChars "port") + , D.cyan (D.fromChars "module") + , D.fromChars "WebSockets" + , D.cyan (D.fromChars "exposing") + , D.fromChars "(send, listen, keepAlive)" + ] + , D.fillSep + [ D.cyan (D.fromChars "port") + , D.cyan (D.fromChars "module") + , D.fromChars "Maps" + , D.cyan (D.fromChars "exposing") + , D.fromChars "(Location, goto)" + ] + ] + , D.reflow <| + "Notice that the module names start with capital letters. That is required!" + ] + ) + + PortModuleExposing exposing_ row col -> + toExposingReport source exposing_ row col + + Effect row col -> + let + region : A.Region + region = + toRegion row col + in + Report.Report "BAD MODULE DECLARATION" region [] <| + Code.toSnippet source region Nothing <| + ( D.reflow <| + "I cannot parse this module declaration:" + , D.reflow <| + "This type of module is reserved for the @elm organization. It is used to define certain effects, avoiding building them into the compiler." + ) + + FreshLine row col -> + let + region : A.Region + region = + toRegion row col + + toBadFirstLineReport : String -> Report.Report + toBadFirstLineReport keyword = + Report.Report "TOO MUCH INDENTATION" region [] <| + Code.toSnippet source region Nothing <| + ( D.reflow <| + "This `" + ++ keyword + ++ "` should not have any spaces before it:" + , D.reflow <| + "Delete the spaces before `" + ++ keyword + ++ "` until there are none left!" + ) + in + case Code.whatIsNext source row col of + Code.Keyword "module" -> + toBadFirstLineReport "module" + + Code.Keyword "import" -> + toBadFirstLineReport "import" + + Code.Keyword "type" -> + toBadFirstLineReport "type" + + Code.Keyword "port" -> + toBadFirstLineReport "port" + + _ -> + Report.Report "SYNTAX PROBLEM" region [] <| + Code.toSnippet source region Nothing <| + ( D.reflow <| + "I got stuck here:" + , D.stack + [ D.reflow <| + "I am not sure what is going on, but I recommend starting an Elm file with the following lines:" + , D.indent 4 <| + D.vcat <| + [ D.fillSep [ D.cyan (D.fromChars "import"), D.fromChars "Html" ] + , D.fromChars "" + , D.fromChars "main =" + , D.fromChars " Html.text " + |> D.a (D.dullyellow (D.fromChars "\"Hello!\"")) + ] + , D.reflow <| + "You should be able to copy those lines directly into your file. Check out the examples at for more help getting started!" + , D.toSimpleNote <| + "This can also happen when something is indented too much!" + ] + ) + + ImportStart row col -> + toImportReport source row col + + ImportName row col -> + let + region : A.Region + region = + toRegion row col + in + Report.Report "EXPECTING IMPORT NAME" region [] <| + Code.toSnippet source region Nothing <| + ( D.reflow <| + "I was parsing an `import` until I got stuck here:" + , D.stack + [ D.reflow <| + "I was expecting to see a module name next, like in these examples:" + , D.indent 4 <| + D.vcat <| + [ D.fillSep + [ D.cyan (D.fromChars "import") + , D.fromChars "Dict" + ] + , D.fillSep + [ D.cyan (D.fromChars "import") + , D.fromChars "Maybe" + ] + , D.fillSep + [ D.cyan (D.fromChars "import") + , D.fromChars "Html.Attributes" + , D.cyan (D.fromChars "as") + , D.fromChars "A" + ] + , D.fillSep + [ D.cyan (D.fromChars "import") + , D.fromChars "Json.Decode" + , D.cyan (D.fromChars "exposing") + , D.fromChars "(..)" + ] + ] + , D.reflow <| + "Notice that the module names all start with capital letters. That is required!" + , D.reflowLink "Read" "imports" "to learn more." + ] + ) + + ImportAs row col -> + toImportReport source row col + + ImportAlias row col -> + let + region : A.Region + region = + toRegion row col + in + Report.Report "EXPECTING IMPORT ALIAS" region [] <| + Code.toSnippet source region Nothing <| + ( D.reflow <| + "I was parsing an `import` until I got stuck here:" + , D.stack + [ D.reflow <| + "I was expecting to see an alias next, like in these examples:" + , D.indent 4 <| + D.vcat <| + [ D.fillSep + [ D.cyan <| D.fromChars "import" + , D.fromChars "Html.Attributes" + , D.cyan <| D.fromChars "as" + , D.fromChars "Attr" + ] + , D.fillSep + [ D.cyan <| D.fromChars "import" + , D.fromChars "WebGL.Texture" + , D.cyan <| D.fromChars "as" + , D.fromChars "Texture" + ] + , D.fillSep + [ D.cyan <| D.fromChars "import" + , D.fromChars "Json.Decode" + , D.cyan <| D.fromChars "as" + , D.fromChars "D" + ] + ] + , D.reflow <| + "Notice that the alias always starts with a capital letter. That is required!" + , D.reflowLink "Read" "imports" "to learn more." + ] + ) + + ImportExposing row col -> + toImportReport source row col + + ImportExposingList exposing_ row col -> + toExposingReport source exposing_ row col + + ImportEnd row col -> + toImportReport source row col + + ImportIndentName row col -> + toImportReport source row col + + ImportIndentAlias row col -> + toImportReport source row col + + ImportIndentExposingList row col -> + let + region : A.Region + region = + toRegion row col + in + Report.Report "UNFINISHED IMPORT" region [] <| + Code.toSnippet source region Nothing <| + ( D.reflow <| + "I was parsing an `import` until I got stuck here:" + , D.stack + [ D.reflow <| + "I was expecting to see the list of exposed values next. For example, here are two ways to expose values from the `Html` module:" + , D.indent 4 <| + D.vcat <| + [ D.fillSep + [ D.cyan <| D.fromChars "import" + , D.fromChars "Html" + , D.cyan <| D.fromChars "exposing" + , D.fromChars "(..)" + ] + , D.fillSep + [ D.cyan <| D.fromChars "import" + , D.fromChars "Html" + , D.cyan <| D.fromChars "exposing" + , D.fromChars "(Html, div, text)" + ] + ] + , D.reflow <| + "I generally recommend the second style. It is more explicit, making it much easier to figure out where values are coming from in large projects!" + ] + ) + + Infix row col -> + let + region : A.Region + region = + toRegion row col + in + Report.Report "BAD INFIX" region [] <| + Code.toSnippet source region Nothing <| + ( D.reflow <| + "Something went wrong in this infix operator declaration:" + , D.reflow <| + "This feature is used by the @elm organization to define the languages built-in operators." + ) + + Declarations decl _ _ -> + toDeclarationsReport syntaxVersion source decl + + + +-- WEIRD END + + +toWeirdEndReport : Code.Source -> Row -> Col -> Report.Report +toWeirdEndReport source row col = + case Code.whatIsNext source row col of + Code.Keyword keyword -> + let + region : A.Region + region = + toKeywordRegion row col keyword + in + Report.Report "RESERVED WORD" region [] <| + Code.toSnippet source region Nothing <| + ( D.reflow "I got stuck on this reserved word:" + , D.reflow <| + ("The name `" ++ keyword ++ "` is reserved, so try using a different name?") + ) + + Code.Operator op -> + let + region : A.Region + region = + toKeywordRegion row col op + in + Report.Report "UNEXPECTED SYMBOL" region [] <| + Code.toSnippet source region Nothing <| + ( D.reflow "I ran into an unexpected symbol:" + , D.reflow <| + ("I was not expecting to see a " ++ op ++ " here. Try deleting it? Maybe I can give a better hint from there?") + ) + + Code.Close term bracket -> + let + region : A.Region + region = + toRegion row col + in + Report.Report ("UNEXPECTED " ++ String.toUpper term) region [] <| + Code.toSnippet source region Nothing <| + ( D.reflow ("I ran into an unexpected " ++ term ++ ":") + , D.reflow ("This " ++ String.fromChar bracket ++ " does not match up with an earlier open " ++ term ++ ". Try deleting it?") + ) + + Code.Lower c cs -> + let + region : A.Region + region = + toKeywordRegion row col (String.cons c cs) + in + Report.Report "UNEXPECTED NAME" region [] <| + Code.toSnippet source region Nothing <| + ( D.reflow "I got stuck on this name:" + , D.reflow "It is confusing me a lot! Normally I can give fairly specific hints, but something is really tripping me up this time." + ) + + Code.Upper c cs -> + let + region : A.Region + region = + toKeywordRegion row col (String.fromChar c ++ cs) + in + Report.Report "UNEXPECTED NAME" region [] <| + Code.toSnippet source region Nothing <| + ( D.reflow "I got stuck on this name:" + , D.reflow "It is confusing me a lot! Normally I can give fairly specific hints, but something is really tripping me up this time." + ) + + Code.Other maybeChar -> + let + region : A.Region + region = + toRegion row col + in + case maybeChar of + Just ';' -> + Report.Report "UNEXPECTED SEMICOLON" region [] <| + Code.toSnippet source region Nothing <| + ( D.reflow "I got stuck on this semicolon:" + , D.stack + [ D.reflow "Try removing it?" + , D.toSimpleNote "Some languages require semicolons at the end of each statement. These are often called C-like languages, and they usually share a lot of language design choices. (E.g. side-effects, for loops, etc.) Elm manages effects with commands and subscriptions instead, so there is no special syntax for \"statements\" and therefore no need to use semicolons to separate them. I think this will make more sense as you work through though!" + ] + ) + + Just ',' -> + Report.Report "UNEXPECTED COMMA" region [] <| + Code.toSnippet source region Nothing <| + ( D.reflow "I got stuck on this comma:" + , D.stack + [ D.reflow "I do not think I am parsing a list or tuple right now. Try deleting the comma?" + , D.toSimpleNote "If this is supposed to be part of a list, the problem may be a bit earlier. Perhaps the opening [ is missing? Or perhaps some value in the list has an extra closing ] that is making me think the list ended earlier? The same kinds of things could be going wrong if this is supposed to be a tuple." + ] + ) + + Just '`' -> + Report.Report "UNEXPECTED CHARACTER" region [] <| + Code.toSnippet source region Nothing <| + ( D.reflow "I got stuck on this character:" + , D.stack + [ D.reflow "It is not used for anything in Elm syntax. It is used for multi-line strings in some languages though, so if you want a string that spans multiple lines, you can use Elm's multi-line string syntax like this:" + , D.dullyellow <| + D.indent 4 <| + D.vcat + [ D.fromChars "\"\"\"" + , D.fromChars "# Multi-line Strings" + , D.fromChars "" + , D.fromChars "- start with triple double quotes" + , D.fromChars "- write whatever you want" + , D.fromChars "- no need to escape newlines or double quotes" + , D.fromChars "- end with triple double quotes" + , D.fromChars "\"\"\"" + ] + , D.reflow "Otherwise I do not know what is going on! Try removing the character?" + ] + ) + + Just '$' -> + Report.Report "UNEXPECTED SYMBOL" region [] <| + Code.toSnippet source region Nothing <| + ( D.reflow "I got stuck on this dollar sign:" + , D.reflow "It is not used for anything in Elm syntax. Are you coming from a language where dollar signs can be used in variable names? If so, try a name that (1) starts with a letter and (2) only contains letters, numbers, and underscores." + ) + + Just c -> + if List.member c [ '#', '@', '!', '%', '~' ] then + Report.Report "UNEXPECTED SYMBOL" region [] <| + Code.toSnippet source region Nothing <| + ( D.reflow "I got stuck on this symbol:" + , D.reflow "It is not used for anything in Elm syntax. Try removing it?" + ) + + else + toWeirdEndSyntaxProblemReport source region + + _ -> + toWeirdEndSyntaxProblemReport source region + + +toWeirdEndSyntaxProblemReport : Code.Source -> A.Region -> Report.Report +toWeirdEndSyntaxProblemReport source region = + Report.Report "SYNTAX PROBLEM" region [] <| + Code.toSnippet source region Nothing <| + ( D.reflow "I got stuck here:" + , D.reflow "Whatever I am running into is confusing me a lot! Normally I can give fairly specific hints, but something is really tripping me up this time." + ) + + + +-- IMPORTS + + +toImportReport : Code.Source -> Row -> Col -> Report.Report +toImportReport source row col = + let + region : A.Region + region = + toRegion row col + in + Report.Report "UNFINISHED IMPORT" region [] <| + Code.toSnippet source region Nothing <| + ( D.reflow "I am partway through parsing an import, but I got stuck here:" + , D.stack + [ D.reflow "Here are some examples of valid `import` declarations:" + , D.indent 4 <| + D.vcat + [ D.fillSep + [ D.cyan <| D.fromChars "import" + , D.fromChars "Html" + ] + , D.fillSep + [ D.cyan <| D.fromChars "import" + , D.fromChars "Html" + , D.cyan <| D.fromChars "as" + , D.fromChars "H" + ] + , D.fillSep + [ D.cyan <| D.fromChars "import" + , D.fromChars "Html" + , D.cyan <| D.fromChars "as" + , D.fromChars "H" + , D.cyan <| D.fromChars "exposing" + , D.fromChars "(..)" + ] + , D.fillSep + [ D.cyan <| D.fromChars "import" + , D.fromChars "Html" + , D.cyan <| D.fromChars "exposing" + , D.fromChars "(Html, div, text)" + ] + ] + , D.reflow "You are probably trying to import a different module, but try to make it look like one of these examples!" + , D.reflowLink "Read" "imports" "to learn more." + ] + ) + + + +-- EXPOSING + + +toExposingReport : Code.Source -> Exposing -> Row -> Col -> Report.Report +toExposingReport source exposing_ startRow startCol = + case exposing_ of + ExposingSpace space row col -> + toSpaceReport source space row col + + ExposingStart row col -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + in + Report.Report "PROBLEM IN EXPOSING" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow "I want to parse exposed values, but I am getting stuck here:" + , D.stack + [ D.fillSep + [ D.fromChars "Exposed" + , D.fromChars "values" + , D.fromChars "are" + , D.fromChars "always" + , D.fromChars "surrounded" + , D.fromChars "by" + , D.fromChars "parentheses." + , D.fromChars "So" + , D.fromChars "try" + , D.fromChars "adding" + , D.fromChars "a" + , D.green (D.fromChars "(") + , D.fromChars "here?" + ] + , D.toSimpleNote "Here are some valid examples of `exposing` for reference:" + , D.indent 4 <| + D.vcat + [ D.fillSep + [ D.cyan <| D.fromChars "import" + , D.fromChars "Html" + , D.cyan <| D.fromChars "exposing" + , D.fromChars "(..)" + ] + , D.fillSep + [ D.cyan <| D.fromChars "import" + , D.fromChars "Html" + , D.cyan <| D.fromChars "exposing" + , D.fromChars "(Html, div, text)" + ] + ] + , D.reflow "If you are getting tripped up, you can just expose everything for now. It should get easier to make an explicit exposing list as you see more examples in the wild." + ] + ) + + ExposingValue row col -> + case Code.whatIsNext source row col of + Code.Keyword keyword -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toKeywordRegion row col keyword + in + Report.Report "RESERVED WORD" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow "I got stuck on this reserved word:" + , D.reflow ("It looks like you are trying to expose `" ++ keyword ++ "` but that is a reserved word. Is there a typo?") + ) + + Code.Operator op -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toKeywordRegion row col op + in + Report.Report "UNEXPECTED SYMBOL" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow "I got stuck on this symbol:" + , D.stack + [ D.reflow "If you are trying to expose an operator, add parentheses around it like this:" + , D.indent 4 <| + (D.dullyellow (D.fromChars op) + |> D.a (D.fromChars " -> ") + |> D.a + (D.green + (D.fromChars "(" + |> D.a (D.fromChars op) + |> D.a (D.fromChars ")") + ) + ) + ) + ] + ) + + _ -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + in + Report.Report "PROBLEM IN EXPOSING" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow "I got stuck while parsing these exposed values:" + , D.stack + [ D.reflow "I do not have an exact recommendation, so here are some valid examples of `exposing` for reference:" + , D.indent 4 <| + D.vcat + [ D.fillSep + [ D.cyan (D.fromChars "import") + , D.fromChars "Html" + , D.cyan (D.fromChars "exposing") + , D.fromChars "(..)" + ] + , D.fillSep + [ D.cyan <| D.fromChars "import" + , D.fromChars "Basics" + , D.cyan <| D.fromChars "exposing" + , D.fromChars "(Int, Float, Bool(..), (+), not, sqrt)" + ] + ] + , D.reflow "These examples show how to expose types, variants, operators, and functions. Everything should be some permutation of these examples, just with different names." + ] + ) + + ExposingOperator row col -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + in + Report.Report "PROBLEM IN EXPOSING" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow "I just saw an open parenthesis, so I was expecting an operator next:" + , D.fillSep + [ D.fromChars "It" + , D.fromChars "is" + , D.fromChars "possible" + , D.fromChars "to" + , D.fromChars "expose" + , D.fromChars "operators," + , D.fromChars "so" + , D.fromChars "I" + , D.fromChars "was" + , D.fromChars "expecting" + , D.fromChars "to" + , D.fromChars "see" + , D.fromChars "something" + , D.fromChars "like" + , D.dullyellow <| D.fromChars "(+)" + , D.fromChars "or" + , D.dullyellow <| D.fromChars "(|=)" + , D.fromChars "or" + , D.dullyellow <| D.fromChars "(||)" + , D.fromChars "after" + , D.fromChars "I" + , D.fromChars "saw" + , D.fromChars "that" + , D.fromChars "open" + , D.fromChars "parenthesis." + ] + ) + + ExposingOperatorReserved op row col -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + in + Report.Report "RESERVED SYMBOL" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow "I cannot expose this as an operator:" + , case op of + BadDot -> + D.reflow "Try getting rid of this entry? Maybe I can give you a better hint after that?" + + BadPipe -> + D.fillSep + [ D.fromChars "Maybe" + , D.fromChars "you" + , D.fromChars "want" + , D.dullyellow <| D.fromChars "(||)" + , D.fromChars "instead?" + ] + + BadArrow -> + D.reflow "Try getting rid of this entry? Maybe I can give you a better hint after that?" + + BadEquals -> + D.fillSep + [ D.fromChars "Maybe" + , D.fromChars "you" + , D.fromChars "want" + , D.dullyellow <| D.fromChars "(==)" + , D.fromChars "instead?" + ] + + BadHasType -> + D.fillSep + [ D.fromChars "Maybe" + , D.fromChars "you" + , D.fromChars "want" + , D.dullyellow <| D.fromChars "(::)" + , D.fromChars "instead?" + ] + ) + + ExposingOperatorRightParen row col -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + in + Report.Report "PROBLEM IN EXPOSING" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow "It looks like you are exposing an operator, but I got stuck here:" + , D.fillSep + [ D.fromChars "I" + , D.fromChars "was" + , D.fromChars "expecting" + , D.fromChars "to" + , D.fromChars "see" + , D.fromChars "the" + , D.fromChars "closing" + , D.fromChars "parenthesis" + , D.fromChars "immediately" + , D.fromChars "after" + , D.fromChars "the" + , D.fromChars "operator." + , D.fromChars "Try" + , D.fromChars "adding" + , D.fromChars "a" + , D.green <| D.fromChars ")" + , D.fromChars "right" + , D.fromChars "here?" + ] + ) + + ExposingEnd row col -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + in + Report.Report "UNFINISHED EXPOSING" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow "I was partway through parsing exposed values, but I got stuck here:" + , D.reflow "Maybe there is a comma missing before this?" + ) + + ExposingTypePrivacy row col -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + in + Report.Report "PROBLEM EXPOSING CUSTOM TYPE VARIANTS" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow "It looks like you are trying to expose the variants of a custom type:" + , D.stack + [ D.fillSep + [ D.fromChars "You" + , D.fromChars "need" + , D.fromChars "to" + , D.fromChars "write" + , D.fromChars "something" + , D.fromChars "like" + , D.dullyellow <| D.fromChars "Status(..)" + , D.fromChars "or" + , D.dullyellow <| D.fromChars "Entity(..)" + , D.fromChars "though." + , D.fromChars "It" + , D.fromChars "is" + , D.fromChars "all" + , D.fromChars "or" + , D.fromChars "nothing," + , D.fromChars "otherwise" + , D.fromChars "`case`" + , D.fromChars "expressions" + , D.fromChars "could" + , D.fromChars "miss" + , D.fromChars "a" + , D.fromChars "variant" + , D.fromChars "and" + , D.fromChars "crash!" + ] + , D.toSimpleNote <| + "It is often best to keep the variants hidden! If someone pattern matches on the variants, it is a MAJOR change if any new variants are added. Suddenly their `case` expressions do not cover all variants! So if you do not need people to pattern match, keep the variants hidden and expose functions to construct values of this type. This way you can add new variants as a MINOR change!" + ] + ) + + ExposingIndentEnd row col -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + in + Report.Report "UNFINISHED EXPOSING" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow "I was partway through parsing exposed values, but I got stuck here:" + , D.stack + [ D.fillSep + [ D.fromChars "I" + , D.fromChars "was" + , D.fromChars "expecting" + , D.fromChars "a" + , D.fromChars "closing" + , D.fromChars "parenthesis." + , D.fromChars "Try" + , D.fromChars "adding" + , D.fromChars "a" + , D.green <| D.fromChars ")" + , D.fromChars "right" + , D.fromChars "here?" + ] + , D.toSimpleNote <| + "I can get confused when there is not enough indentation, so if you already have a closing parenthesis, it probably just needs some spaces in front of it." + ] + ) + + ExposingIndentValue row col -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + in + Report.Report "UNFINISHED EXPOSING" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow "I was partway through parsing exposed values, but I got stuck here:" + , D.reflow "I was expecting another value to expose." + ) + + + +-- SPACES + + +toSpaceReport : Code.Source -> Space -> Row -> Col -> Report.Report +toSpaceReport source space row col = + case space of + HasTab -> + let + region : A.Region + region = + toRegion row col + in + Report.Report "NO TABS" region [] <| + Code.toSnippet source region Nothing <| + ( D.reflow "I ran into a tab, but tabs are not allowed in Elm files." + , D.reflow "Replace the tab with spaces." + ) + + EndlessMultiComment -> + let + region : A.Region + region = + toWiderRegion row col 2 + in + Report.Report "ENDLESS COMMENT" region [] <| + Code.toSnippet source region Nothing <| + ( D.reflow "I cannot find the end of this multi-line comment:" + , D.stack + -- "{-" + [ D.reflow "Add a -} somewhere after this to end the comment." + , D.toSimpleHint "Multi-line comments can be nested in Elm, so {- {- -} -} is a comment that happens to contain another comment. Like parentheses and curly braces, the start and end markers must always be balanced. Maybe that is the problem?" + ] + ) + + + +-- DECLARATIONS + + +toRegion : Row -> Col -> A.Region +toRegion row col = + let + pos : A.Position + pos = + A.Position row col + in + A.Region pos pos + + +toWiderRegion : Row -> Col -> Int -> A.Region +toWiderRegion row col extra = + A.Region + (A.Position row col) + (A.Position row (col + extra)) + + +toKeywordRegion : Row -> Col -> String -> A.Region +toKeywordRegion row col keyword = + A.Region + (A.Position row col) + (A.Position row (col + String.length keyword)) + + +toDeclarationsReport : SyntaxVersion -> Code.Source -> Decl -> Report.Report +toDeclarationsReport syntaxVersion source decl = + case decl of + DeclStart row col -> + toDeclStartReport source row col + + DeclSpace space row col -> + toSpaceReport source space row col + + Port port_ row col -> + toPortReport source port_ row col + + DeclType declType row col -> + toDeclTypeReport source declType row col + + DeclDef name declDef row col -> + toDeclDefReport syntaxVersion source name declDef row col + + DeclFreshLineAfterDocComment row col -> + let + region : A.Region + region = + toRegion row col + in + Report.Report "EXPECTING DECLARATION" region [] <| + Code.toSnippet source region Nothing <| + ( D.reflow "I just saw a doc comment, but then I got stuck here:" + , D.reflow "I was expecting to see the corresponding declaration next, starting on a fresh line with no indentation." + ) + + +toDeclStartReport : Code.Source -> Row -> Col -> Report.Report +toDeclStartReport source row col = + case Code.whatIsNext source row col of + Code.Close term bracket -> + let + region : A.Region + region = + toRegion row col + in + Report.Report ("STRAY " ++ String.toUpper term) region [] <| + Code.toSnippet source region Nothing <| + ( D.reflow ("I was not expecting to see a " ++ term ++ " here:") + , D.reflow ("This " ++ String.fromChar bracket ++ " does not match up with an earlier open " ++ term ++ ". Try deleting it?") + ) + + Code.Keyword keyword -> + let + region : A.Region + region = + toKeywordRegion row col keyword + in + Report.Report "RESERVED WORD" region [] <| + Code.toSnippet source region Nothing <| + ( D.reflow ("I was not expecting to run into the `" ++ keyword ++ "` keyword here:") + , case keyword of + "import" -> + D.reflow "It is reserved for declaring imports at the top of your module. If you want another import, try moving it up top with the other imports. If you want to define a value or function, try changing the name to something else!" + + "case" -> + D.stack + [ D.reflow "It is reserved for writing `case` expressions. Try using a different name?" + , D.toSimpleNote "If you are trying to write a `case` expression, it needs to be part of a definition. So you could write something like this instead:" + , D.indent 4 <| + D.vcat + [ D.indent 0 <| D.fillSep [ D.fromChars "getWidth", D.fromChars "maybeWidth", D.fromChars "=" ] + , D.indent 2 <| D.fillSep [ D.cyan (D.fromChars "case"), D.fromChars "maybeWidth", D.cyan (D.fromChars "of") ] + , D.indent 4 <| D.fillSep [ D.blue (D.fromChars "Just"), D.fromChars "width", D.fromChars "->" ] + , D.indent 6 <| D.fillSep [ D.fromChars "width", D.fromChars "+", D.dullyellow (D.fromChars "200") ] + , D.fromChars "" + , D.indent 4 <| D.fillSep [ D.blue (D.fromChars "Nothing"), D.fromChars "->" ] + , D.indent 6 <| D.fillSep [ D.dullyellow (D.fromChars "400") ] + ] + , D.reflow "This defines a `getWidth` function that you can use elsewhere in your program." + ] + + "if" -> + D.stack + [ D.reflow "It is reserved for writing `if` expressions. Try using a different name?" + , D.toSimpleNote "If you are trying to write an `if` expression, it needs to be part of a definition. So you could write something like this instead:" + , D.indent 4 <| + D.vcat + [ D.fromChars "greet name =" + , D.fillSep + [ D.fromChars " " + , D.cyan <| D.fromChars "if" + , D.fromChars "name" + , D.fromChars "==" + , D.dullyellow <| D.fromChars "\"Abraham Lincoln\"" + , D.cyan <| D.fromChars "then" + , D.dullyellow <| D.fromChars "\"Greetings Mr. President.\"" + , D.cyan <| D.fromChars "else" + , D.dullyellow <| D.fromChars "\"Hey!\"" + ] + ] + , D.reflow "This defines a `greet` function that you can use elsewhere in your program." + ] + + _ -> + D.reflow "It is a reserved word. Try changing the name to something else?" + ) + + Code.Upper c cs -> + let + region : A.Region + region = + toRegion row col + in + Report.Report "UNEXPECTED CAPITAL LETTER" region [] <| + Code.toSnippet source region Nothing <| + ( D.reflow "Declarations always start with a lower-case letter, so I am getting stuck here:" + , D.stack + [ D.fillSep + [ D.fromChars "Try" + , D.fromChars "a" + , D.fromChars "name" + , D.fromChars "like" + , D.green (D.fromChars (String.cons (Char.toLower c) cs)) + , D.fromChars "instead?" + ] + , D.toSimpleNote "Here are a couple valid declarations for reference:" + , D.indent 4 <| + D.vcat + [ D.fromChars "greet : String -> String" + , D.fromChars "greet name =" + , D.fromChars " " + |> D.a (D.dullyellow (D.fromChars "\"Hello \"")) + |> D.a (D.fromChars " ++ name ++ ") + |> D.a (D.dullyellow (D.fromChars "\"!\"")) + , D.fromChars "" + , D.cyan (D.fromChars "type" |> D.a (D.fromChars " User = Anonymous | LoggedIn String")) + ] + , D.reflow "Notice that they always start with a lower-case letter. Capitalization matters!" + ] + ) + + Code.Other (Just char) -> + let + region : A.Region + region = + toRegion row col + in + if List.member char [ '(', '{', '[', '+', '-', '*', '/', '^', '&', '|', '"', '\'', '!', '@', '#', '$', '%' ] then + Report.Report "UNEXPECTED SYMBOL" region [] <| + Code.toSnippet source region Nothing <| + ( D.reflow ("I am getting stuck because this line starts with the " ++ String.fromChar char ++ " symbol:") + , D.stack + [ D.reflow "When a line has no spaces at the beginning, I expect it to be a declaration like one of these:" + , D.indent 4 <| + D.vcat + [ D.fromChars "greet : String -> String" + , D.fromChars "greet name =" + , D.fromChars " " + |> D.a (D.dullyellow (D.fromChars "\"Hello \"")) + |> D.a (D.fromChars " ++ name ++ ") + |> D.a (D.dullyellow (D.fromChars "\"!\"")) + , D.fromChars "" + , D.cyan (D.fromChars "type") + |> D.a (D.fromChars " User = Anonymous | LoggedIn String") + ] + , D.reflow "If this is not supposed to be a declaration, try adding some spaces before it?" + ] + ) + + else + toDeclStartWeirdDeclarationReport source region + + _ -> + toDeclStartWeirdDeclarationReport source (toRegion row col) + + +toDeclStartWeirdDeclarationReport : Code.Source -> A.Region -> Report.Report +toDeclStartWeirdDeclarationReport source region = + Report.Report "WEIRD DECLARATION" region [] <| + Code.toSnippet source region Nothing <| + ( D.reflow "I am trying to parse a declaration, but I am getting stuck here:" + , D.stack + [ D.reflow "When a line has no spaces at the beginning, I expect it to be a declaration like one of these:" + , D.indent 4 <| + D.vcat + [ D.fromChars "greet : String -> String" + , D.fromChars "greet name =" + , D.fromChars " " + |> D.a (D.dullyellow (D.fromChars "\"Hello \"")) + |> D.a (D.fromChars " ++ name ++ ") + |> D.a (D.dullyellow (D.fromChars "\"!\"")) + , D.fromChars "" + , D.cyan (D.fromChars "type") |> D.a (D.fromChars " User = Anonymous | LoggedIn String") + ] + , D.reflow "Try to make your declaration look like one of those? Or if this is not supposed to be a declaration, try adding some spaces before it?" + ] + ) + + + +-- PORT + + +toPortReport : Code.Source -> Port -> Row -> Col -> Report.Report +toPortReport source port_ startRow startCol = + case port_ of + PortSpace space row col -> + toSpaceReport source space row col + + PortName row col -> + case Code.whatIsNext source row col of + Code.Keyword keyword -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toKeywordRegion row col keyword + in + Report.Report "RESERVED WORD" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow "I cannot handle ports with names like this:" + , D.reflow ("You are trying to make a port named `" ++ keyword ++ "` but that is a reserved word. Try using some other name?") + ) + + _ -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + in + Report.Report "PORT PROBLEM" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow "I just saw the start of a `port` declaration, but then I got stuck here:" + , D.stack + [ D.fillSep + [ D.fromChars "I" + , D.fromChars "was" + , D.fromChars "expecting" + , D.fromChars "to" + , D.fromChars "see" + , D.fromChars "a" + , D.fromChars "name" + , D.fromChars "like" + , D.dullyellow <| D.fromChars "send" + , D.fromChars "or" + , D.dullyellow <| D.fromChars "receive" + , D.fromChars "next." + , D.fromChars "Something" + , D.fromChars "that" + , D.fromChars "starts" + , D.fromChars "with" + , D.fromChars "a" + , D.fromChars "lower-case" + , D.fromChars "letter." + ] + , portNote + ] + ) + + PortColon row col -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + in + Report.Report "PORT PROBLEM" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow "I just saw the start of a `port` declaration, but then I got stuck here:" + , D.stack + [ D.reflow "I was expecting to see a colon next. And then a type that tells me what type of values are going to flow through." + , portNote + ] + ) + + PortType tipe row col -> + toTypeReport source TC_Port tipe row col + + PortIndentName row col -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + in + Report.Report "UNFINISHED PORT" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow "I just saw the start of a `port` declaration, but then I got stuck here:" + , D.stack + [ D.fillSep + [ D.fromChars "I" + , D.fromChars "was" + , D.fromChars "expecting" + , D.fromChars "to" + , D.fromChars "see" + , D.fromChars "a" + , D.fromChars "name" + , D.fromChars "like" + , D.dullyellow <| D.fromChars "send" + , D.fromChars "or" + , D.dullyellow <| D.fromChars "receive" + , D.fromChars "next." + , D.fromChars "Something" + , D.fromChars "that" + , D.fromChars "starts" + , D.fromChars "with" + , D.fromChars "a" + , D.fromChars "lower-case" + , D.fromChars "letter." + ] + , portNote + ] + ) + + PortIndentColon row col -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + in + Report.Report "UNFINISHED PORT" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow "I just saw the start of a `port` declaration, but then I got stuck here:" + , D.stack + [ D.reflow "I was expecting to see a colon next. And then a type that tells me what type of values are going to flow through." + , portNote + ] + ) + + PortIndentType row col -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + in + Report.Report "UNFINISHED PORT" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow "I just saw the start of a `port` declaration, but then I got stuck here:" + , D.stack + [ D.reflow "I was expecting to see a type next. Here are examples of outgoing and incoming ports for reference:" + , D.indent 4 <| + D.vcat + [ D.fillSep + [ D.cyan (D.fromChars "port") + , D.fromChars "send" + , D.fromChars ":" + , D.fromChars "String -> Cmd msg" + ] + , D.fillSep + [ D.cyan (D.fromChars "port") + , D.fromChars "receive" + , D.fromChars ":" + , D.fromChars "(String -> msg) -> Sub msg" + ] + ] + , D.reflow "The first line defines a `send` port so you can send strings out to JavaScript. Maybe you send them on a WebSocket or put them into IndexedDB. The second line defines a `receive` port so you can receive strings from JavaScript. Maybe you get receive messages when new WebSocket messages come in or when an entry in IndexedDB changes for some external reason." + ] + ) + + +portNote : D.Doc +portNote = + D.stack + [ D.toSimpleNote "Here are some example `port` declarations for reference:" + , D.indent 4 <| + D.vcat + [ D.fillSep + [ D.cyan <| D.fromChars "port" + , D.fromChars "send" + , D.fromChars ":" + , D.fromChars "String -> Cmd msg" + ] + , D.fillSep + [ D.cyan <| D.fromChars "port" + , D.fromChars "receive" + , D.fromChars ":" + , D.fromChars "(String -> msg) -> Sub msg" + ] + ] + , D.reflow "The first line defines a `send` port so you can send strings out to JavaScript. Maybe you send them on a WebSocket or put them into IndexedDB. The second line defines a `receive` port so you can receive strings from JavaScript. Maybe you get receive messages when new WebSocket messages come in or when the IndexedDB is changed for some external reason." + ] + + + +-- DECL TYPE + + +toDeclTypeReport : Code.Source -> DeclType -> Row -> Col -> Report.Report +toDeclTypeReport source declType startRow startCol = + case declType of + DT_Space space row col -> + toSpaceReport source space row col + + DT_Name row col -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + in + Report.Report "EXPECTING TYPE NAME" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow "I think I am parsing a type declaration, but I got stuck here:" + , D.stack + [ D.fillSep + [ D.fromChars "I" + , D.fromChars "was" + , D.fromChars "expecting" + , D.fromChars "a" + , D.fromChars "name" + , D.fromChars "like" + , D.dullyellow <| D.fromChars "Status" + , D.fromChars "or" + , D.dullyellow <| D.fromChars "Style" + , D.fromChars "next." + , D.fromChars "Just" + , D.fromChars "make" + , D.fromChars "sure" + , D.fromChars "it" + , D.fromChars "is" + , D.fromChars "a" + , D.fromChars "name" + , D.fromChars "that" + , D.fromChars "starts" + , D.fromChars "with" + , D.fromChars "a" + , D.fromChars "capital" + , D.fromChars "letter!" + ] + , customTypeNote + ] + ) + + DT_Alias typeAlias row col -> + toTypeAliasReport source typeAlias row col + + DT_Union customType row col -> + toCustomTypeReport source customType row col + + DT_IndentName row col -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + in + Report.Report "EXPECTING TYPE NAME" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow "I think I am parsing a type declaration, but I got stuck here:" + , D.stack + [ D.fillSep + [ D.fromChars "I" + , D.fromChars "was" + , D.fromChars "expecting" + , D.fromChars "a" + , D.fromChars "name" + , D.fromChars "like" + , D.dullyellow <| D.fromChars "Status" + , D.fromChars "or" + , D.dullyellow <| D.fromChars "Style" + , D.fromChars "next." + , D.fromChars "Just" + , D.fromChars "make" + , D.fromChars "sure" + , D.fromChars "it" + , D.fromChars "is" + , D.fromChars "a" + , D.fromChars "name" + , D.fromChars "that" + , D.fromChars "starts" + , D.fromChars "with" + , D.fromChars "a" + , D.fromChars "capital" + , D.fromChars "letter!" + ] + , customTypeNote + ] + ) + + +toTypeAliasReport : Code.Source -> TypeAlias -> Row -> Col -> Report.Report +toTypeAliasReport source typeAlias startRow startCol = + case typeAlias of + AliasSpace space row col -> + toSpaceReport source space row col + + AliasName row col -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + in + Report.Report "EXPECTING TYPE ALIAS NAME" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow "I am partway through parsing a type alias, but I got stuck here:" + , D.stack + [ D.fillSep + [ D.fromChars "I" + , D.fromChars "was" + , D.fromChars "expecting" + , D.fromChars "a" + , D.fromChars "name" + , D.fromChars "like" + , D.dullyellow <| D.fromChars "Person" + , D.fromChars "or" + , D.dullyellow <| D.fromChars "Point" + , D.fromChars "next." + , D.fromChars "Just" + , D.fromChars "make" + , D.fromChars "sure" + , D.fromChars "it" + , D.fromChars "is" + , D.fromChars "a" + , D.fromChars "name" + , D.fromChars "that" + , D.fromChars "starts" + , D.fromChars "with" + , D.fromChars "a" + , D.fromChars "capital" + , D.fromChars "letter!" + ] + , typeAliasNote + ] + ) + + AliasEquals row col -> + case Code.whatIsNext source row col of + Code.Keyword keyword -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toKeywordRegion row col keyword + in + Report.Report "RESERVED WORD" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow "I ran into a reserved word unexpectedly while parsing this type alias:" + , D.stack + [ D.reflow <| + ("It looks like you are trying use `" + ++ keyword + ++ "` as a type variable, but it is a reserved word. Try using a different name?" + ) + , typeAliasNote + ] + ) + + _ -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + in + Report.Report "PROBLEM IN TYPE ALIAS" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow "I am partway through parsing a type alias, but I got stuck here:" + , D.stack + [ D.reflow "I was expecting to see a type variable or an equals sign next." + , typeAliasNote + ] + ) + + AliasBody tipe row col -> + toTypeReport source TC_TypeAlias tipe row col + + AliasIndentEquals row col -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + in + Report.Report "UNFINISHED TYPE ALIAS" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow "I am partway through parsing a type alias, but I got stuck here:" + , D.stack + [ D.reflow "I was expecting to see a type variable or an equals sign next." + , typeAliasNote + ] + ) + + AliasIndentBody row col -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + in + Report.Report "UNFINISHED TYPE ALIAS" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow "I am partway through parsing a type alias, but I got stuck here:" + , D.stack + [ D.fillSep + [ D.fromChars "I" + , D.fromChars "was" + , D.fromChars "expecting" + , D.fromChars "to" + , D.fromChars "see" + , D.fromChars "a" + , D.fromChars "type" + , D.fromChars "next." + , D.fromChars "Something" + , D.fromChars "as" + , D.fromChars "simple" + , D.fromChars "as" + , D.dullyellow <| D.fromChars "Int" + , D.fromChars "or" + , D.dullyellow <| D.fromChars "Float" + , D.fromChars "would" + , D.fromChars "work!" + ] + , typeAliasNote + ] + ) + + +typeAliasNote : D.Doc +typeAliasNote = + D.stack + [ D.toSimpleNote "Here is an example of a valid `type alias` for reference:" + , D.vcat + [ D.indent 4 <| + D.fillSep + [ D.cyan (D.fromChars "type") + , D.cyan (D.fromChars "alias") + , D.fromChars "Person" + , D.fromChars "=" + ] + , D.indent 6 <| + D.vcat + [ D.fromChars "{ name : String" + , D.fromChars ", age : Int" + , D.fromChars ", height : Float" + , D.fromChars "}" + ] + ] + , D.reflow <| + "This would let us use `Person` as a shorthand for that record type. Using this shorthand makes type annotations much easier to read, and makes changing code easier if you decide later that there is more to a person than age and height!" + ] + + +toCustomTypeReport : Code.Source -> CustomType -> Row -> Col -> Report.Report +toCustomTypeReport source customType startRow startCol = + case customType of + CT_Space space row col -> + toSpaceReport source space row col + + CT_Name row col -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + in + Report.Report "EXPECTING TYPE NAME" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow "I think I am parsing a type declaration, but I got stuck here:" + , D.stack + [ D.fillSep + [ D.fromChars "I" + , D.fromChars "was" + , D.fromChars "expecting" + , D.fromChars "a" + , D.fromChars "name" + , D.fromChars "like" + , D.dullyellow <| D.fromChars "Status" + , D.fromChars "or" + , D.dullyellow <| D.fromChars "Style" + , D.fromChars "next." + , D.fromChars "Just" + , D.fromChars "make" + , D.fromChars "sure" + , D.fromChars "it" + , D.fromChars "is" + , D.fromChars "a" + , D.fromChars "name" + , D.fromChars "that" + , D.fromChars "starts" + , D.fromChars "with" + , D.fromChars "a" + , D.fromChars "capital" + , D.fromChars "letter!" + ] + , customTypeNote + ] + ) + + CT_Equals row col -> + case Code.whatIsNext source row col of + Code.Keyword keyword -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toKeywordRegion row col keyword + in + Report.Report "RESERVED WORD" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow "I ran into a reserved word unexpectedly while parsing this custom type:" + , D.stack + [ D.reflow <| + "It looks like you are trying use `" + ++ keyword + ++ "` as a type variable, but it is a reserved word. Try using a different name?" + , customTypeNote + ] + ) + + _ -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + in + Report.Report "PROBLEM IN CUSTOM TYPE" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow "I am partway through parsing a custom type, but I got stuck here:" + , D.stack + [ D.reflow "I was expecting to see a type variable or an equals sign next." + , customTypeNote + ] + ) + + CT_Bar row col -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + in + Report.Report "PROBLEM IN CUSTOM TYPE" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow "I am partway through parsing a custom type, but I got stuck here:" + , D.stack + [ D.reflow "I was expecting to see a vertical bar like | next." + , customTypeNote + ] + ) + + CT_Variant row col -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + in + Report.Report "PROBLEM IN CUSTOM TYPE" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow "I am partway through parsing a custom type, but I got stuck here:" + , D.stack + [ D.fillSep + [ D.fromChars "I" + , D.fromChars "was" + , D.fromChars "expecting" + , D.fromChars "to" + , D.fromChars "see" + , D.fromChars "a" + , D.fromChars "variant" + , D.fromChars "name" + , D.fromChars "next." + , D.fromChars "Something" + , D.fromChars "like" + , D.dullyellow <| D.fromChars "Success" + , D.fromChars "or" + , D.dullyellow (D.fromChars "Sandwich") + |> D.a (D.fromChars ".") + , D.fromChars "Any" + , D.fromChars "name" + , D.fromChars "that" + , D.fromChars "starts" + , D.fromChars "with" + , D.fromChars "a" + , D.fromChars "capital" + , D.fromChars "letter" + , D.fromChars "really!" + ] + , customTypeNote + ] + ) + + CT_VariantArg tipe row col -> + toTypeReport source TC_CustomType tipe row col + + CT_IndentEquals row col -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + in + Report.Report "UNFINISHED CUSTOM TYPE" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow "I am partway through parsing a custom type, but I got stuck here:" + , D.stack + [ D.reflow "I was expecting to see a type variable or an equals sign next." + , customTypeNote + ] + ) + + CT_IndentBar row col -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + in + Report.Report "UNFINISHED CUSTOM TYPE" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow "I am partway through parsing a custom type, but I got stuck here:" + , D.stack + [ D.reflow "I was expecting to see a vertical bar like | next." + , customTypeNote + ] + ) + + CT_IndentAfterBar row col -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + in + Report.Report "UNFINISHED CUSTOM TYPE" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow "I am partway through parsing a custom type, but I got stuck here:" + , D.stack + [ D.reflow "I just saw a vertical bar, so I was expecting to see another variant defined next." + , customTypeNote + ] + ) + + CT_IndentAfterEquals row col -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + in + Report.Report "UNFINISHED CUSTOM TYPE" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow "I am partway through parsing a custom type, but I got stuck here:" + , D.stack + [ D.reflow "I just saw an equals sign, so I was expecting to see the first variant defined next." + , customTypeNote + ] + ) + + +customTypeNote : D.Doc +customTypeNote = + D.stack + [ D.toSimpleNote "Here is an example of a valid `type` declaration for reference:" + , D.vcat + [ D.indent 4 <| D.fillSep [ D.cyan (D.fromChars "type"), D.cyan (D.fromChars "Status") ] + , D.indent 6 <| D.fillSep [ D.fromChars "=", D.fromChars "Failure" ] + , D.indent 6 <| D.fillSep [ D.fromChars "|", D.fromChars "Waiting" ] + , D.indent 6 <| D.fillSep [ D.fromChars "|", D.fromChars "Success", D.fromChars "String" ] + ] + , D.reflow <| + "This defines a new `Status` type with three variants. This could be useful if we are waiting for an HTTP request. Maybe we start with `Waiting` and then switch to `Failure` or `Success \"message from server\"` depending on how things go. Notice that the Success variant has some associated data, allowing us to store a String if the request goes well!" + ] + + + +-- DECL DEF + + +toDeclDefReport : SyntaxVersion -> Code.Source -> Name -> DeclDef -> Row -> Col -> Report.Report +toDeclDefReport syntaxVersion source name declDef startRow startCol = + case declDef of + DeclDefSpace space row col -> + toSpaceReport source space row col + + DeclDefEquals row col -> + case Code.whatIsNext source row col of + Code.Keyword keyword -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toKeywordRegion row col keyword + in + Report.Report "RESERVED WORD" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.fillSep + [ D.fromChars "The" + , D.fromChars "name" + , D.fromChars "`" + |> D.a (D.cyan (D.fromChars keyword)) + |> D.a (D.fromChars "`") + , D.fromChars "is" + , D.fromChars "reserved" + , D.fromChars "in" + , D.fromChars "Elm," + , D.fromChars "so" + , D.fromChars "it" + , D.fromChars "cannot" + , D.fromChars "be" + , D.fromChars "used" + , D.fromChars "as" + , D.fromChars "an" + , D.fromChars "argument" + , D.fromChars "here:" + ] + , D.stack + [ D.reflow "Try renaming it to something else." + , case keyword of + "as" -> + D.toFancyNote + [ D.fromChars "This" + , D.fromChars "keyword" + , D.fromChars "is" + , D.fromChars "reserved" + , D.fromChars "for" + , D.fromChars "pattern" + , D.fromChars "matches" + , D.fromChars "like" + , D.fromChars "((x,y)" + , D.cyan <| D.fromChars "as" + , D.fromChars "point)" + , D.fromChars "where" + , D.fromChars "you" + , D.fromChars "want" + , D.fromChars "to" + , D.fromChars "name" + , D.fromChars "a" + , D.fromChars "tuple" + , D.fromChars "and" + , D.fromChars "the" + , D.fromChars "values" + , D.fromChars "it" + , D.fromChars "contains." + ] + + _ -> + D.toSimpleNote <| + "The `" + ++ keyword + ++ "` keyword has a special meaning in Elm, so it can only be used in certain situations." + ] + ) + + Code.Operator "->" -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toWiderRegion row col 2 + in + Report.Report "MISSING COLON?" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow "I was not expecting to see an arrow here:" + , D.stack + [ D.fillSep + [ D.fromChars "This" + , D.fromChars "usually" + , D.fromChars "means" + , D.fromChars "a" + , D.green <| D.fromChars ":" + , D.fromChars "is" + , D.fromChars "missing" + , D.fromChars "a" + , D.fromChars "bit" + , D.fromChars "earlier" + , D.fromChars "in" + , D.fromChars "a" + , D.fromChars "type" + , D.fromChars "annotation." + , D.fromChars "It" + , D.fromChars "could" + , D.fromChars "be" + , D.fromChars "something" + , D.fromChars "else" + , D.fromChars "though," + , D.fromChars "so" + , D.fromChars "here" + , D.fromChars "is" + , D.fromChars "a" + , D.fromChars "valid" + , D.fromChars "definition" + , D.fromChars "for" + , D.fromChars "reference:" + ] + , D.indent 4 <| + D.vcat + [ D.fromChars "greet : String -> String" + , D.fromChars "greet name =" + , D.fromChars " " + |> D.a (D.dullyellow (D.fromChars "\"Hello \"")) + |> D.a (D.fromChars " ++ name ++ ") + |> D.a (D.dullyellow (D.fromChars "\"!\"")) + ] + , D.reflow <| + "Try to use that format with your `" + ++ name + ++ "` definition!" + ] + ) + + Code.Operator op -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toKeywordRegion row col op + in + Report.Report "UNEXPECTED SYMBOL" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow "I was not expecting to see this symbol here:" + , D.stack + [ D.reflow "I am not sure what is going wrong exactly, so here is a valid definition (with an optional type annotation) for reference:" + , D.indent 4 <| + D.vcat + [ D.fromChars "greet : String -> String" + , D.fromChars "greet name =" + , D.fromChars " " + |> D.a (D.dullyellow (D.fromChars "\"Hello \"")) + |> D.a (D.fromChars " ++ name ++ ") + |> D.a (D.dullyellow (D.fromChars "\"!\"")) + ] + , D.reflow <| + "Try to use that format with your `" + ++ name + ++ "` definition!" + ] + ) + + _ -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + in + Report.Report "PROBLEM IN DEFINITION" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow <| + "I got stuck while parsing the `" + ++ name + ++ "` definition:" + , D.stack + [ D.reflow "I am not sure what is going wrong exactly, so here is a valid definition (with an optional type annotation) for reference:" + , D.indent 4 <| + D.vcat + [ D.fromChars "greet : String -> String" + , D.fromChars "greet name =" + , D.fromChars " " + |> D.a (D.dullyellow (D.fromChars "\"Hello \"")) + |> D.a (D.fromChars " ++ name ++ ") + |> D.a (D.dullyellow (D.fromChars "\"!\"")) + ] + , D.reflow "Try to use that format!" + ] + ) + + DeclDefType tipe row col -> + toTypeReport source (TC_Annotation name) tipe row col + + DeclDefArg pattern row col -> + toPatternReport syntaxVersion source PArg pattern row col + + DeclDefBody expr row col -> + toExprReport syntaxVersion source (InDef name startRow startCol) expr row col + + DeclDefNameRepeat row col -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + in + Report.Report "EXPECTING DEFINITION" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow <| + "I just saw the type annotation for `" + ++ name + ++ "` so I was expecting to see its definition here:" + , D.stack + [ D.reflow "Type annotations always appear directly above the relevant definition, without anything else in between. (Not even doc comments!)" + , declDefNote + ] + ) + + DeclDefNameMatch defName row col -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + in + Report.Report "NAME MISMATCH" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow <| + "I just saw a type annotation for `" + ++ name + ++ "`, but it is followed by a definition for `" + ++ defName + ++ "`:" + , D.stack + [ D.reflow "These names do not match! Is there a typo?" + , D.indent 4 <| + D.fillSep + [ D.dullyellow (D.fromName defName) + , D.fromChars "->" + , D.green (D.fromName name) + ] + ] + ) + + DeclDefIndentType row col -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + in + Report.Report "UNFINISHED DEFINITION" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow <| + "I got stuck while parsing the `" + ++ name + ++ "` type annotation:" + , D.stack + [ D.reflow "I just saw a colon, so I am expecting to see a type next." + , declDefNote + ] + ) + + DeclDefIndentEquals row col -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + in + Report.Report "UNFINISHED DEFINITION" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow <| + "I got stuck while parsing the `" + ++ name + ++ "` definition:" + , D.stack + [ D.reflow "I was expecting to see an argument or an equals sign next." + , declDefNote + ] + ) + + DeclDefIndentBody row col -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + in + Report.Report "UNFINISHED DEFINITION" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow <| + "I got stuck while parsing the `" + ++ name + ++ "` definition:" + , D.stack + [ D.reflow "I was expecting to see an expression next. What is it equal to?" + , declDefNote + ] + ) + + +declDefNote : D.Doc +declDefNote = + D.stack + [ D.reflow "Here is a valid definition (with a type annotation) for reference:" + , D.indent 4 <| + D.vcat + [ D.fromChars "greet : String -> String" + , D.fromChars "greet name =" + , D.fromChars " " + |> D.a (D.dullyellow (D.fromChars "\"Hello \"")) + |> D.a (D.fromChars " ++ name ++ ") + |> D.a (D.dullyellow (D.fromChars "\"!\"")) + ] + , D.reflow "The top line (called a \"type annotation\") is optional. You can leave it off if you want. As you get more comfortable with Elm and as your project grows, it becomes more and more valuable to add them though! They work great as compiler-verified documentation, and they often improve error messages!" + ] + + + +-- CONTEXT + + +type Context + = InNode Node Row Col Context + | InDef Name Row Col + | InDestruct Row Col + + +type Node + = NRecord + | NParens + | NList + | NFunc + | NCond + | NThen + | NElse + | NCase + | NBranch + + +getDefName : Context -> Maybe Name +getDefName context = + case context of + InDestruct _ _ -> + Nothing + + InDef name _ _ -> + Just name + + InNode _ _ _ c -> + getDefName c + + +isWithin : Node -> Context -> Bool +isWithin desiredNode context = + case context of + InDestruct _ _ -> + False + + InDef _ _ _ -> + False + + InNode actualNode _ _ _ -> + desiredNode == actualNode + + + +-- EXPR REPORTS + + +toExprReport : SyntaxVersion -> Code.Source -> Context -> Expr -> Row -> Col -> Report.Report +toExprReport syntaxVersion source context expr startRow startCol = + case expr of + Let let_ row col -> + toLetReport syntaxVersion source context let_ row col + + Case case_ row col -> + toCaseReport syntaxVersion source context case_ row col + + If if_ row col -> + toIfReport syntaxVersion source context if_ row col + + List list row col -> + toListReport syntaxVersion source context list row col + + Record record row col -> + toRecordReport syntaxVersion source context record row col + + Tuple tuple row col -> + toTupleReport syntaxVersion source context tuple row col + + Func func row col -> + toFuncReport syntaxVersion source context func row col + + Dot row col -> + let + region : A.Region + region = + toRegion row col + in + Report.Report "EXPECTING RECORD ACCESSOR" region [] <| + Code.toSnippet source region Nothing <| + ( D.reflow "I was expecting to see a record accessor here:" + , D.fillSep + [ D.fromChars "Something" + , D.fromChars "like" + , D.dullyellow <| D.fromChars ".name" + , D.fromChars "or" + , D.dullyellow <| D.fromChars ".price" + , D.fromChars "that" + , D.fromChars "accesses" + , D.fromChars "a" + , D.fromChars "value" + , D.fromChars "from" + , D.fromChars "a" + , D.fromChars "record." + ] + ) + + Access row col -> + let + region : A.Region + region = + toRegion row col + in + Report.Report "EXPECTING RECORD ACCESSOR" region [] <| + Code.toSnippet source region Nothing <| + ( D.reflow "I am trying to parse a record accessor here:" + , D.stack + [ D.fillSep + [ D.fromChars "Something" + , D.fromChars "like" + , D.dullyellow <| D.fromChars ".name" + , D.fromChars "or" + , D.dullyellow <| D.fromChars ".price" + , D.fromChars "that" + , D.fromChars "accesses" + , D.fromChars "a" + , D.fromChars "value" + , D.fromChars "from" + , D.fromChars "a" + , D.fromChars "record." + ] + , D.toSimpleNote "Record field names must start with a lower case letter!" + ] + ) + + OperatorRight op row col -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + + isMath : Bool + isMath = + List.member op [ "-", "+", "*", "/", "^" ] + in + Report.Report "MISSING EXPRESSION" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow <| + "I just saw a " + ++ op + ++ " " + ++ (if isMath then + "sign" + + else + "operator" + ) + ++ ", so I am getting stuck here:" + , if isMath then + D.fillSep + [ D.fromChars "I" + , D.fromChars "was" + , D.fromChars "expecting" + , D.fromChars "to" + , D.fromChars "see" + , D.fromChars "an" + , D.fromChars "expression" + , D.fromChars "next." + , D.fromChars "Something" + , D.fromChars "like" + , D.dullyellow <| D.fromChars "42" + , D.fromChars "or" + , D.dullyellow <| D.fromChars "1000" + , D.fromChars "that" + , D.fromChars "makes" + , D.fromChars "sense" + , D.fromChars "with" + , D.fromChars "a" + , D.fromName op + , D.fromChars "sign." + ] + + else if op == "&&" || op == "||" then + D.fillSep + [ D.fromChars "I" + , D.fromChars "was" + , D.fromChars "expecting" + , D.fromChars "to" + , D.fromChars "see" + , D.fromChars "an" + , D.fromChars "expression" + , D.fromChars "next." + , D.fromChars "Something" + , D.fromChars "like" + , D.dullyellow <| D.fromChars "True" + , D.fromChars "or" + , D.dullyellow <| D.fromChars "False" + , D.fromChars "that" + , D.fromChars "makes" + , D.fromChars "sense" + , D.fromChars "with" + , D.fromChars "boolean" + , D.fromChars "logic." + ] + + else if op == "|>" then + D.reflow "I was expecting to see a function next." + + else if op == "<|" then + D.reflow "I was expecting to see an argument next." + + else + D.reflow "I was expecting to see an expression next." + ) + + OperatorReserved operator row col -> + toOperatorReport source context operator row col + + Start row col -> + let + ( contextRow, contextCol, aThing ) = + case context of + InDestruct r c -> + ( r, c, "a definition" ) + + InDef name r c -> + ( r, c, "the `" ++ name ++ "` definition" ) + + InNode NRecord r c _ -> + ( r, c, "a record" ) + + InNode NParens r c _ -> + ( r, c, "some parentheses" ) + + InNode NList r c _ -> + ( r, c, "a list" ) + + InNode NFunc r c _ -> + ( r, c, "an anonymous function" ) + + InNode NCond r c _ -> + ( r, c, "an `if` expression" ) + + InNode NThen r c _ -> + ( r, c, "an `if` expression" ) + + InNode NElse r c _ -> + ( r, c, "an `if` expression" ) + + InNode NCase r c _ -> + ( r, c, "a `case` expression" ) + + InNode NBranch r c _ -> + ( r, c, "a `case` expression" ) + + surroundings : A.Region + surroundings = + A.Region (A.Position contextRow contextCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + in + Report.Report "MISSING EXPRESSION" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow <| "I am partway through parsing " ++ aThing ++ ", but I got stuck here:" + , D.stack + [ D.fillSep + [ D.fromChars "I" + , D.fromChars "was" + , D.fromChars "expecting" + , D.fromChars "to" + , D.fromChars "see" + , D.fromChars "an" + , D.fromChars "expression" + , D.fromChars "like" + , D.dullyellow <| D.fromChars "42" + , D.fromChars "or" + , D.dullyellow (D.fromChars "\"hello\"") + |> D.a (D.fromChars ".") + , D.fromChars "Once" + , D.fromChars "there" + , D.fromChars "is" + , D.fromChars "something" + , D.fromChars "there," + , D.fromChars "I" + , D.fromChars "can" + , D.fromChars "probably" + , D.fromChars "give" + , D.fromChars "a" + , D.fromChars "more" + , D.fromChars "specific" + , D.fromChars "hint!" + ] + , D.toSimpleNote "This can also happen if I run into reserved words like `let` or `as` unexpectedly. Or if I run into operators in unexpected spots. Point is, there are a couple ways I can get confused and give sort of weird advice!" + ] + ) + + Char char row col -> + toCharReport source char row col + + String_ string row col -> + toStringReport source string row col + + Number number row col -> + toNumberReport syntaxVersion source number row col + + Space space row col -> + toSpaceReport source space row col + + EndlessShader row col -> + let + region : A.Region + region = + toWiderRegion row col 6 + in + Report.Report "ENDLESS SHADER" region [] <| + Code.toSnippet source region Nothing <| + ( D.reflow "I cannot find the end of this shader:" + , D.reflow "Add a |] somewhere after this to end the shader." + ) + + ShaderProblem problem row col -> + let + region : A.Region + region = + toRegion row col + in + Report.Report "SHADER PROBLEM" region [] <| + Code.toSnippet source region Nothing <| + ( D.reflow "I ran into a problem while parsing this GLSL block." + , D.stack + [ D.reflow "I use a 3rd party GLSL parser for now, and I did my best to extract their error message:" + , D.indent 4 <| D.vcat <| List.map D.fromChars (List.filter ((/=) "") (String.lines problem)) + ] + ) + + IndentOperatorRight op row col -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + in + Report.Report "MISSING EXPRESSION" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow <| "I was expecting to see an expression after this " ++ op ++ " operator:" + , D.stack + [ D.fillSep + [ D.fromChars "You" + , D.fromChars "can" + , D.fromChars "just" + , D.fromChars "put" + , D.fromChars "anything" + , D.fromChars "for" + , D.fromChars "now," + , D.fromChars "like" + , D.dullyellow <| D.fromChars "42" + , D.fromChars "or" + , D.dullyellow (D.fromChars "\"hello\"") + |> D.a (D.fromChars ".") + , D.fromChars "Once" + , D.fromChars "there" + , D.fromChars "is" + , D.fromChars "something" + , D.fromChars "there," + , D.fromChars "I" + , D.fromChars "can" + , D.fromChars "probably" + , D.fromChars "give" + , D.fromChars "a" + , D.fromChars "more" + , D.fromChars "specific" + , D.fromChars "hint!" + ] + , D.toSimpleNote <| "I may be getting confused by your indentation? The easiest way to make sure this is not an indentation problem is to put the expression on the right of the " ++ op ++ " operator on the same line." + ] + ) + + + +-- CHAR + + +toCharReport : Code.Source -> Char -> Row -> Col -> Report.Report +toCharReport source char row col = + case char of + CharEndless -> + let + region : A.Region + region = + toRegion row col + in + Report.Report "MISSING SINGLE QUOTE" region [] <| + Code.toSnippet source region Nothing <| + ( D.reflow + "I thought I was parsing a character, but I got to the end of the line without seeing the closing single quote:" + , D.reflow "Add a closing single quote here!" + ) + + CharEscape escape -> + toEscapeReport source escape row col + + CharNotString width -> + let + region : A.Region + region = + toWiderRegion row col width + in + Report.Report "NEEDS DOUBLE QUOTES" region [] <| + Code.toSnippet source region Nothing <| + ( D.fromChars "The following string uses single quotes:" + , D.stack + [ D.fromChars "Please switch to double quotes instead:" + , D.indent 4 <| + (D.dullyellow (D.fromChars "'this'") + |> D.a (D.fromChars " => ") + |> D.a (D.green (D.fromChars "\"this\"")) + ) + , D.toSimpleNote + "Elm uses double quotes for strings like \"hello\", whereas it uses single quotes for individual characters like 'a' and 'ø'. This distinction helps with code like (String.any (\\c -> c == 'X') \"90210\") where you are inspecting individual characters." + ] + ) + + + +-- STRING + + +toStringReport : Code.Source -> String_ -> Row -> Col -> Report.Report +toStringReport source string row col = + case string of + StringEndless_Single -> + let + region : A.Region + region = + toRegion row col + in + Report.Report "ENDLESS STRING" region [] <| + Code.toSnippet source region Nothing <| + ( D.reflow + "I got to the end of the line without seeing the closing double quote:" + , D.stack + [ D.fillSep + [ D.fromChars "Strings" + , D.fromChars "look" + , D.fromChars "like" + , D.green <| D.fromChars "\"this\"" + , D.fromChars "with" + , D.fromChars "double" + , D.fromChars "quotes" + , D.fromChars "on" + , D.fromChars "each" + , D.fromChars "end." + , D.fromChars "Is" + , D.fromChars "the" + , D.fromChars "closing" + , D.fromChars "double" + , D.fromChars "quote" + , D.fromChars "missing" + , D.fromChars "in" + , D.fromChars "your" + , D.fromChars "code?" + ] + , D.toSimpleNote + "For a string that spans multiple lines, you can use the multi-line string syntax like this:" + , D.dullyellow <| + D.indent 4 <| + D.vcat + [ D.fromChars "\"\"\"" + , D.fromChars "# Multi-line Strings" + , D.fromChars "" + , D.fromChars "- start with triple double quotes" + , D.fromChars "- write whatever you want" + , D.fromChars "- no need to escape newlines or double quotes" + , D.fromChars "- end with triple double quotes" + , D.fromChars "\"\"\"" + ] + ] + ) + + StringEndless_Multi -> + let + region : A.Region + region = + toWiderRegion row col 3 + in + Report.Report "ENDLESS STRING" region [] <| + Code.toSnippet source region Nothing <| + ( D.reflow + "I cannot find the end of this multi-line string:" + , D.stack + [ D.reflow "Add a \"\"\" somewhere after this to end the string." + , D.toSimpleNote "Here is a valid multi-line string for reference:" + , D.dullyellow <| + D.indent 4 <| + D.vcat + [ D.fromChars "\"\"\"" + , D.fromChars "# Multi-line Strings" + , D.fromChars "" + , D.fromChars "- start with triple double quotes" + , D.fromChars "- write whatever you want" + , D.fromChars "- no need to escape newlines or double quotes" + , D.fromChars "- end with triple double quotes" + , D.fromChars "\"\"\"" + ] + ] + ) + + StringEscape escape -> + toEscapeReport source escape row col + + + +-- ESCAPES + + +toEscapeReport : Code.Source -> Escape -> Row -> Col -> Report.Report +toEscapeReport source escape row col = + case escape of + EscapeUnknown -> + let + region : A.Region + region = + toWiderRegion row col 2 + in + Report.Report "UNKNOWN ESCAPE" region [] <| + Code.toSnippet source region Nothing <| + ( D.reflow "Backslashes always start escaped characters, but I do not recognize this one:" + , D.stack + [ D.reflow "Valid escape characters include:" + , D.dullyellow <| + D.indent 4 <| + D.vcat + [ D.fromChars "\\n" + , D.fromChars "\\r" + , D.fromChars "\\t" + , D.fromChars "\\\"" + , D.fromChars "\\'" + , D.fromChars "\\\\" + , D.fromChars "\\u{003D}" + ] + , D.reflow "Do you want one of those instead? Maybe you need \\\\ to escape a backslash?" + , D.toSimpleNote "The last style lets encode ANY character by its Unicode code point. That means \\u{0009} and \\t are the same. You can use that style for anything not covered by the other six escapes!" + ] + ) + + BadUnicodeFormat width -> + let + region : A.Region + region = + toWiderRegion row col width + in + Report.Report "BAD UNICODE ESCAPE" region [] <| + Code.toSnippet source region Nothing <| + ( D.reflow "I ran into an invalid Unicode escape:" + , D.stack + [ D.reflow "Here are some examples of valid Unicode escapes:" + , D.dullyellow <| + D.indent 4 <| + D.vcat + [ D.fromChars "\\u{0041}" + , D.fromChars "\\u{03BB}" + , D.fromChars "\\u{6728}" + , D.fromChars "\\u{1F60A}" + ] + , D.reflow "Notice that the code point is always surrounded by curly braces. Maybe you are missing the opening or closing curly brace?" + ] + ) + + BadUnicodeCode width -> + let + region : A.Region + region = + toWiderRegion row col width + in + Report.Report "BAD UNICODE ESCAPE" region [] <| + Code.toSnippet source region Nothing <| + ( D.reflow "This is not a valid code point:" + , D.reflow "The valid code points are between 0 and 10FFFF inclusive." + ) + + BadUnicodeLength width numDigits badCode -> + let + region : A.Region + region = + toWiderRegion row col width + in + Report.Report "BAD UNICODE ESCAPE" region [] <| + Code.toSnippet source region Nothing <| + if numDigits < 4 then + ( D.reflow "Every code point needs at least four digits:" + , let + goodCode : String + goodCode = + String.repeat (4 - numDigits) "0" ++ String.toUpper (Hex.toString badCode) + + suggestion : D.Doc + suggestion = + D.fromChars ("\\u{" ++ goodCode ++ "}") + in + D.fillSep + [ D.fromChars "Try" + , D.green suggestion + , D.fromChars "instead?" + ] + ) + + else + ( D.reflow "This code point has too many digits:" + , D.fillSep + [ D.fromChars "Valid" + , D.fromChars "code" + , D.fromChars "points" + , D.fromChars "are" + , D.fromChars "between" + , D.green <| D.fromChars "\\u{0000}" + , D.fromChars "and" + , D.green <| D.fromChars "\\u{10FFFF}" + , D.fromChars "," + , D.fromChars "so" + , D.fromChars "try" + , D.fromChars "trimming" + , D.fromChars "any" + , D.fromChars "leading" + , D.fromChars "zeros" + , D.fromChars "until" + , D.fromChars "you" + , D.fromChars "have" + , D.fromChars "between" + , D.fromChars "four" + , D.fromChars "and" + , D.fromChars "six" + , D.fromChars "digits." + ] + ) + + + +-- NUMBERS + + +toNumberReport : SyntaxVersion -> Code.Source -> Number -> Row -> Col -> Report.Report +toNumberReport syntaxVersion source number row col = + let + region : A.Region + region = + toRegion row col + in + case number of + NumberEnd -> + Report.Report "WEIRD NUMBER" region [] <| + Code.toSnippet source region Nothing <| + ( D.reflow "I thought I was reading a number, but I ran into some weird stuff here:" + , D.stack + [ D.reflow "I recognize numbers in the following formats:" + , D.indent 4 <| + D.vcat + (case syntaxVersion of + SV.Elm -> + [ D.fromChars "42" + , D.fromChars "3.14" + , D.fromChars "6.022e23" + , D.fromChars "0x002B" + ] + + SV.Guida -> + [ D.fromChars "42" + , D.fromChars "10_000" + , D.fromChars "3.14" + , D.fromChars "6.022e23" + , D.fromChars "0x002B" + , D.fromChars "0b01010110_00111000" + ] + ) + , D.reflow "So is there a way to write it like one of those?" + ] + ) + + NumberDot int -> + Report.Report "WEIRD NUMBER" region [] <| + Code.toSnippet source region Nothing <| + ( D.reflow "Numbers cannot end with a dot like this:" + , D.fillSep + [ D.fromChars "Switching" + , D.fromChars "to" + , D.green (D.fromChars (String.fromInt int)) + , D.fromChars "or" + , D.green (D.fromChars (String.fromInt int ++ ".0")) + , D.fromChars "will" + , D.fromChars "work" + , D.fromChars "though!" + ] + ) + + NumberHexDigit -> + Report.Report "WEIRD HEXIDECIMAL" region [] <| + Code.toSnippet source region Nothing <| + ( D.reflow "I thought I was reading a hexidecimal number until I got here:" + , D.stack + [ D.reflow "Valid hexidecimal digits include 0123456789abcdefABCDEF, so I can only recognize things like this:" + , D.indent 4 <| + D.vcat + [ D.fromChars "0x2B" + , D.fromChars "0x002B" + , D.fromChars "0x00ffb3" + ] + ] + ) + + NumberBinDigit -> + Report.Report "WEIRD BINARY LITERAL" region [] <| + Code.toSnippet source region Nothing <| + ( D.reflow "I thought I was reading a binary literal until I got here:" + , D.stack + [ D.reflow "Valid binary digits include 0 and 1, so I can only recognize things like this:" + , D.indent 4 <| + D.vcat + [ D.fromChars "0x10" + , D.fromChars "0x0010" + , D.fromChars "0b0101_0110_0011_1000" + ] + ] + ) + + NumberNoLeadingZero -> + Report.Report "LEADING ZEROS" region [] <| + Code.toSnippet source region Nothing <| + ( D.reflow "I do not accept numbers with leading zeros:" + , D.stack + [ D.reflow "Just delete the leading zeros and it should work!" + , D.toSimpleNote "Some languages let you to specify octal numbers by adding a leading zero. So in C, writing 0111 is the same as writing 73. Some people are used to that, but others probably want it to equal 111. Either path is going to surprise people from certain backgrounds, so Elm tries to avoid this whole situation." + ] + ) + + NumberNoLeadingOrTrailingUnderscores -> + Report.Report "LEADING OR TRAILING UNDERSCORE" region [] <| + Code.toSnippet source region Nothing <| + ( D.reflow "I do not accept numbers with leading or trailing underscores:" + , D.stack + [ D.reflow "Just delete the leading or trailing underscore and it should work!" + , D.toSimpleNote "Numbers should not have leading or trailing underscores, as this can make them ambiguous and harder to read or parse correctly. To maintain clarity and follow syntax rules, underscores should only appear between digits." + ] + ) + + NumberNoConsecutiveUnderscores -> + Report.Report "CONSICUTIVE UNDERSCORES" region [] <| + Code.toSnippet source region Nothing <| + ( D.reflow "I do not accept numbers with consecutive underscores:" + , D.stack + [ D.reflow "Just delete the consecutive underscore and it should work!" + , D.toSimpleNote "Numbers should not contain consecutive underscores, as this can lead to confusion and misinterpretation of the value. Use single underscores only between digits to improve readability without breaking the format." + ] + ) + + NumberNoUnderscoresAdjacentToDecimalOrExponent -> + Report.Report "UNDERSCORE ADJACENT TO DECIMAL POINT, E, OR +/-" region [] <| + Code.toSnippet source region Nothing <| + ( D.reflow "I do not accept numbers with underscores directly next to a decimal point, e, or the +/- signs:" + , D.stack + [ D.reflow "Just delete the underscores directly next to a decimal point, e, or the +/- signs and it should work!" + , D.toSimpleNote "Underscores must not appear directly next to a decimal point, e, or the +/- signs in scientific notation, as this disrupts the structure of the number. Keep underscores between digits only to ensure the number remains valid and clearly formatted." + ] + ) + + NumberNoUnderscoresAdjacentToHexadecimalPreFix -> + Report.Report "UNDERSCORE ADJACENT TO HEXADECIMAL PREFIX 0X" region [] <| + Code.toSnippet source region Nothing <| + ( D.reflow "I do not accept numbers with underscores directly next to the hexadecimal prefix 0x:" + , D.stack + [ D.reflow "Just delete the underscores directly next to the hexadecimal prefix 0x and it should work!" + , D.toSimpleNote "Underscores must not appear directly next to the hexadecimal prefix 0x, as this breaks the structure of the number and causes a syntax error. Always place underscores only between valid hexadecimal digits for proper formatting and readability." + ] + ) + + NumberNoUnderscoresAdjacentToBinaryPreFix -> + Report.Report "UNDERSCORE ADJACENT TO BINARY PREFIX 0B" region [] <| + Code.toSnippet source region Nothing <| + ( D.reflow "I do not accept numbers with underscores directly next to the binary prefix 0b:" + , D.stack + [ D.reflow "Just delete the underscores directly next to the binary prefix 0b and it should work!" + , D.toSimpleNote "Underscores must not appear directly next to the binary prefix 0b, as this breaks the structure of the number and causes a syntax error. Always place underscores only between valid binary digits for proper formatting and readability." + ] + ) + + + +-- OPERATORS + + +toOperatorReport : Code.Source -> Context -> BadOperator -> Row -> Col -> Report.Report +toOperatorReport source context operator row col = + case operator of + BadDot -> + let + region : A.Region + region = + toRegion row col + in + Report.Report "UNEXPECTED SYMBOL" region [] <| + Code.toSnippet source region Nothing <| + ( D.fromChars "I was not expecting this dot:" + , D.reflow "Dots are for record access and decimal points, so they cannot float around on their own. Maybe there is some extra whitespace?" + ) + + BadPipe -> + let + region : A.Region + region = + toRegion row col + in + Report.Report "UNEXPECTED SYMBOL" region [] <| + Code.toSnippet source region Nothing <| + ( D.reflow "I was not expecting this vertical bar:" + , D.reflow "Vertical bars should only appear in custom type declarations. Maybe you want || instead?" + ) + + BadArrow -> + let + region : A.Region + region = + toWiderRegion row col 2 + in + Report.Report "UNEXPECTED ARROW" region [] <| + Code.toSnippet source region Nothing <| + if isWithin NCase context then + ( D.reflow "I am parsing a `case` expression right now, but this arrow is confusing me:" + , D.stack + [ D.reflow "Maybe the `of` keyword is missing on a previous line?" + , noteForCaseError + ] + ) + + else if isWithin NBranch context then + ( D.reflow + "I am parsing a `case` expression right now, but this arrow is confusing me:" + , D.stack + [ D.reflow + "It makes sense to see arrows around here, so I suspect it is something earlier. Maybe this pattern is indented a bit farther than the previous patterns?" + , noteForCaseIndentError + ] + ) + + else + ( D.reflow + "I was partway through parsing an expression when I got stuck on this arrow:" + , D.stack + [ D.fromChars "Arrows should only appear in `case` expressions and anonymous functions.\nMaybe it was supposed to be a > sign instead?" + , D.toSimpleNote + "The syntax for anonymous functions is (\\x -> x + 1) so the arguments all appear after the backslash and before the arrow. Maybe a backslash is missing earlier?" + ] + ) + + BadEquals -> + let + region : A.Region + region = + toRegion row col + in + Report.Report "UNEXPECTED EQUALS" region [] <| + Code.toSnippet source region Nothing <| + ( D.reflow + "I was not expecting to see this equals sign:" + , D.stack + [ D.reflow "Maybe you want == instead? To check if two values are equal?" + , D.toSimpleNote <| + if isWithin NRecord context then + "Records look like { x = 3, y = 4 } with the equals sign right after the field name. So maybe you forgot a comma?" + + else + case getDefName context of + Nothing -> + "I may be getting confused by your indentation. I need all definitions to be indented exactly the same amount, so if this is meant to be a new definition, it may have too many spaces in front of it." + + Just name -> + "I may be getting confused by your indentation. I think I am still parsing the `" + ++ name + ++ "` definition. Is this supposed to be part of a definition after that? If so, the problem may be a bit before the equals sign. I need all definitions to be indented exactly the same amount, so the problem may be that this new definition has too many spaces in front of it." + ] + ) + + BadHasType -> + let + region : A.Region + region = + toRegion row col + in + Report.Report "UNEXPECTED SYMBOL" region [] <| + Code.toSnippet source region Nothing <| + ( D.reflow + "I was not expecting to run into the \"has type\" symbol here:" + , case getDefName context of + Nothing -> + D.fillSep + [ D.fromChars "Maybe" + , D.fromChars "you" + , D.fromChars "want" + , D.green <| D.fromChars "::" + , D.fromChars "instead?" + , D.fromChars "To" + , D.fromChars "put" + , D.fromChars "something" + , D.fromChars "on" + , D.fromChars "the" + , D.fromChars "front" + , D.fromChars "of" + , D.fromChars "a" + , D.fromChars "list?" + ] + + Just name -> + D.stack + [ D.fillSep + [ D.fromChars "Maybe" + , D.fromChars "you" + , D.fromChars "want" + , D.green <| D.fromChars "::" + , D.fromChars "instead?" + , D.fromChars "To" + , D.fromChars "put" + , D.fromChars "something" + , D.fromChars "on" + , D.fromChars "the" + , D.fromChars "front" + , D.fromChars "of" + , D.fromChars "a" + , D.fromChars "list?" + ] + , D.toSimpleNote <| + "The single colon is reserved for type annotations and record types, but I think I am parsing the definition of `" + ++ name + ++ "` right now." + , D.toSimpleNote <| + "I may be getting confused by your indentation. Is this supposed to be part of a type annotation AFTER the `" + ++ name + ++ "` definition? If so, the problem may be a bit before the \"has type\" symbol. I need all definitions to be exactly aligned (with exactly the same indentation) so the problem may be that this new definition is indented a bit too much." + ] + ) + + + +-- CASE + + +toLetReport : SyntaxVersion -> Code.Source -> Context -> Let -> Row -> Col -> Report.Report +toLetReport syntaxVersion source context let_ startRow startCol = + case let_ of + LetSpace space row col -> + toSpaceReport source space row col + + LetIn row col -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + in + Report.Report "LET PROBLEM" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow + "I was partway through parsing a `let` expression, but I got stuck here:" + , D.stack + [ D.fillSep + [ D.fromChars "Based" + , D.fromChars "on" + , D.fromChars "the" + , D.fromChars "indentation," + , D.fromChars "I" + , D.fromChars "was" + , D.fromChars "expecting" + , D.fromChars "to" + , D.fromChars "see" + , D.fromChars "the" + , D.cyan <| D.fromChars "in" + , D.fromChars "keyword" + , D.fromChars "next." + , D.fromChars "Is" + , D.fromChars "there" + , D.fromChars "a" + , D.fromChars "typo?" + ] + , D.toSimpleNote + "This can also happen if you are trying to define another value within the `let` but it is not indented enough. Make sure each definition has exactly the same amount of spaces before it. They should line up exactly!" + ] + ) + + LetDefAlignment _ row col -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + in + Report.Report "LET PROBLEM" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow + "I was partway through parsing a `let` expression, but I got stuck here:" + , D.stack + [ D.fillSep + [ D.fromChars "Based" + , D.fromChars "on" + , D.fromChars "the" + , D.fromChars "indentation," + , D.fromChars "I" + , D.fromChars "was" + , D.fromChars "expecting" + , D.fromChars "to" + , D.fromChars "see" + , D.fromChars "the" + , D.cyan <| D.fromChars "in" + , D.fromChars "keyword" + , D.fromChars "next." + , D.fromChars "Is" + , D.fromChars "there" + , D.fromChars "a" + , D.fromChars "typo?" + ] + , D.toSimpleNote + "This can also happen if you are trying to define another value within the `let` but it is not indented enough. Make sure each definition has exactly the same amount of spaces before it. They should line up exactly!" + ] + ) + + LetDefName row col -> + case Code.whatIsNext source row col of + Code.Keyword keyword -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toKeywordRegion row col keyword + in + Report.Report "RESERVED WORD" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow + "I was partway through parsing a `let` expression, but I got stuck here:" + , D.reflow <| + "It looks like you are trying to use `" + ++ keyword + ++ "` as a variable name, but it is a reserved word! Try using a different name instead." + ) + + _ -> + toUnfinishLetReport source row col startRow startCol <| + D.reflow + "I was expecting the name of a definition next." + + LetDef name def row col -> + toLetDefReport syntaxVersion source name def row col + + LetDestruct destruct row col -> + toLetDestructReport syntaxVersion source destruct row col + + LetBody expr row col -> + toExprReport syntaxVersion source context expr row col + + LetIndentDef row col -> + toUnfinishLetReport source row col startRow startCol <| + D.reflow + "I was expecting a value to be defined here." + + LetIndentIn row col -> + toUnfinishLetReport source row col startRow startCol <| + D.fillSep + [ D.fromChars "I" + , D.fromChars "was" + , D.fromChars "expecting" + , D.fromChars "to" + , D.fromChars "see" + , D.fromChars "the" + , D.cyan <| D.fromChars "in" + , D.fromChars "keyword" + , D.fromChars "next." + , D.fromChars "Or" + , D.fromChars "maybe" + , D.fromChars "more" + , D.fromChars "of" + , D.fromChars "that" + , D.fromChars "expression?" + ] + + LetIndentBody row col -> + toUnfinishLetReport source row col startRow startCol <| + D.reflow + "I was expecting an expression next. Tell me what should happen with the value you just defined!" + + +toUnfinishLetReport : Code.Source -> Row -> Col -> Row -> Col -> D.Doc -> Report.Report +toUnfinishLetReport source row col startRow startCol message = + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + in + Report.Report "UNFINISHED LET" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow "I was partway through parsing a `let` expression, but I got stuck here:" + , D.stack + [ message + , D.toSimpleNote "Here is an example with a valid `let` expression for reference:" + , D.indent 4 <| + D.vcat + [ D.indent 0 <| + D.fillSep + [ D.fromChars "viewPerson" + , D.fromChars "person" + , D.fromChars "=" + ] + , D.indent 2 <| D.fillSep [ D.cyan (D.fromChars "let") ] + , D.indent 4 <| D.fillSep [ D.fromChars "fullName", D.fromChars "=" ] + , D.indent 6 <| + D.fillSep + [ D.fromChars "person.firstName" + , D.fromChars "++" + , D.dullyellow (D.fromChars "\" \"") + , D.fromChars "++" + , D.fromChars "person.lastName" + ] + , D.indent 2 <| D.fillSep [ D.cyan (D.fromChars "in") ] + , D.indent 2 <| + D.fillSep + [ D.fromChars "div" + , D.fromChars "[]" + , D.fromChars "[" + , D.fromChars "text" + , D.fromChars "fullName" + , D.fromChars "]" + ] + ] + , D.reflow "Here we defined a `viewPerson` function that turns a person into some HTML. We use a `let` expression to define the `fullName` we want to show. Notice the indentation! The `fullName` is indented more than the `let` keyword, and the actual value of `fullName` is indented a bit more than that. That is important!" + ] + ) + + +toLetDefReport : SyntaxVersion -> Code.Source -> Name -> Def -> Row -> Col -> Report.Report +toLetDefReport syntaxVersion source name def startRow startCol = + case def of + DefSpace space row col -> + toSpaceReport source space row col + + DefType tipe row col -> + toTypeReport source (TC_Annotation name) tipe row col + + DefNameRepeat row col -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + in + Report.Report "EXPECTING DEFINITION" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow ("I just saw the type annotation for `" ++ name ++ "` so I was expecting to see its definition here:") + , D.stack + [ D.reflow "Type annotations always appear directly above the relevant definition, without anything else in between." + , defNote + ] + ) + + DefNameMatch defName row col -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + in + Report.Report "NAME MISMATCH" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow ("I just saw a type annotation for `" ++ name ++ "`, but it is followed by a definition for `" ++ defName ++ "`:") + , D.stack + [ D.reflow "These names do not match! Is there a typo?" + , D.indent 4 <| + D.fillSep + [ D.dullyellow (D.fromName defName) + , D.fromChars "->" + , D.green (D.fromName name) + ] + ] + ) + + DefArg pattern row col -> + toPatternReport syntaxVersion source PArg pattern row col + + DefEquals row col -> + case Code.whatIsNext source row col of + Code.Keyword keyword -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toKeywordRegion row col keyword + in + Report.Report "RESERVED WORD" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.fillSep + [ D.fromChars "The" + , D.fromChars "name" + , D.fromChars "`" + |> D.a (D.cyan (D.fromChars keyword)) + |> D.a (D.fromChars "`") + , D.fromChars "is" + , D.fromChars "reserved" + , D.fromChars "in" + , D.fromChars "Elm," + , D.fromChars "so" + , D.fromChars "it" + , D.fromChars "cannot" + , D.fromChars "be" + , D.fromChars "used" + , D.fromChars "as" + , D.fromChars "an" + , D.fromChars "argument" + , D.fromChars "here:" + ] + , D.stack + [ D.reflow "Try renaming it to something else." + , case keyword of + "as" -> + D.toFancyNote + [ D.fromChars "This" + , D.fromChars "keyword" + , D.fromChars "is" + , D.fromChars "reserved" + , D.fromChars "for" + , D.fromChars "pattern" + , D.fromChars "matches" + , D.fromChars "like" + , D.fromChars "((x,y)" + , D.cyan <| D.fromChars "as" + , D.fromChars "point)" + , D.fromChars "where" + , D.fromChars "you" + , D.fromChars "want" + , D.fromChars "to" + , D.fromChars "name" + , D.fromChars "a" + , D.fromChars "tuple" + , D.fromChars "and" + , D.fromChars "the" + , D.fromChars "values" + , D.fromChars "it" + , D.fromChars "contains." + ] + + _ -> + D.toSimpleNote <| + "The `" + ++ keyword + ++ "` keyword has a special meaning in Elm, so it can only be used in certain situations." + ] + ) + + Code.Operator "->" -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toWiderRegion row col 2 + in + Report.Report "MISSING COLON?" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow "I was not expecting to see an arrow here:" + , D.stack + [ D.fillSep + [ D.fromChars "This" + , D.fromChars "usually" + , D.fromChars "means" + , D.fromChars "a" + , D.green <| D.fromChars ":" + , D.fromChars "is" + , D.fromChars "missing" + , D.fromChars "a" + , D.fromChars "bit" + , D.fromChars "earlier" + , D.fromChars "in" + , D.fromChars "a" + , D.fromChars "type" + , D.fromChars "annotation." + , D.fromChars "It" + , D.fromChars "could" + , D.fromChars "be" + , D.fromChars "something" + , D.fromChars "else" + , D.fromChars "though," + , D.fromChars "so" + , D.fromChars "here" + , D.fromChars "is" + , D.fromChars "a" + , D.fromChars "valid" + , D.fromChars "definition" + , D.fromChars "for" + , D.fromChars "reference:" + ] + , D.indent 4 <| + D.vcat + [ D.fromChars "greet : String -> String" + , D.fromChars "greet name =" + , D.fromChars " " + |> D.a (D.dullyellow (D.fromChars "\"Hello \"")) + |> D.a (D.fromChars " ++ name ++ ") + |> D.a (D.dullyellow (D.fromChars "\"!\"")) + ] + , D.reflow ("Try to use that format with your `" ++ name ++ "` definition!") + ] + ) + + Code.Operator op -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toKeywordRegion row col op + in + Report.Report "UNEXPECTED SYMBOL" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow "I was not expecting to see this symbol here:" + , D.stack + [ D.reflow "I am not sure what is going wrong exactly, so here is a valid definition (with an optional type annotation) for reference:" + , D.indent 4 <| + D.vcat + [ D.fromChars "greet : String -> String" + , D.fromChars "greet name =" + , D.fromChars " " + |> D.a (D.dullyellow (D.fromChars "\"Hello \"")) + |> D.a (D.fromChars " ++ name ++ ") + |> D.a (D.dullyellow (D.fromChars "\"!\"")) + ] + , D.reflow ("Try to use that format with your `" ++ name ++ "` definition!") + ] + ) + + _ -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + in + Report.Report "PROBLEM IN DEFINITION" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow ("I got stuck while parsing the `" ++ name ++ "` definition:") + , D.stack + [ D.reflow "I am not sure what is going wrong exactly, so here is a valid definition (with an optional type annotation) for reference:" + , D.indent 4 <| + D.vcat + [ D.fromChars "greet : String -> String" + , D.fromChars "greet name =" + , D.fromChars " " + |> D.a (D.dullyellow (D.fromChars "\"Hello \"")) + |> D.a (D.fromChars " ++ name ++ ") + |> D.a (D.dullyellow (D.fromChars "\"!\"")) + ] + , D.reflow "Try to use that format!" + ] + ) + + DefBody expr row col -> + toExprReport syntaxVersion source (InDef name startRow startCol) expr row col + + DefIndentEquals row col -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + in + Report.Report "UNFINISHED DEFINITION" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow ("I got stuck while parsing the `" ++ name ++ "` definition:") + , D.stack + [ D.reflow "I was expecting to see an argument or an equals sign next." + , defNote + ] + ) + + DefIndentType row col -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + in + Report.Report "UNFINISHED DEFINITION" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow ("I got stuck while parsing the `" ++ name ++ "` type annotation:") + , D.stack + [ D.reflow "I just saw a colon, so I am expecting to see a type next." + , defNote + ] + ) + + DefIndentBody row col -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + in + Report.Report "UNFINISHED DEFINITION" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow ("I got stuck while parsing the `" ++ name ++ "` definition:") + , D.stack + [ D.reflow "I was expecting to see an expression next. What is it equal to?" + , declDefNote + ] + ) + + DefAlignment indent row col -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + + offset : Int + offset = + indent - col + in + Report.Report "PROBLEM IN DEFINITION" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow ("I got stuck while parsing the `" ++ name ++ "` definition:") + , D.reflow + ("I just saw a type annotation indented " + ++ String.fromInt indent + ++ " spaces, so I was expecting to see the corresponding definition next with the exact same amount of indentation. It looks like this line needs " + ++ String.fromInt offset + ++ " more " + ++ (if offset == 1 then + "space" + + else + "spaces" + ) + ++ "?" + ) + ) + + +defNote : D.Doc +defNote = + D.stack + [ D.reflow "Here is a valid definition (with a type annotation) for reference:" + , D.indent 4 <| + D.vcat + [ D.fromChars "greet : String -> String\n" + , D.fromChars "greet name =" + , D.fromChars " " + |> D.a (D.dullyellow (D.fromChars "\"Hello \"")) + |> D.a (D.fromChars " ++ name ++ ") + |> D.a (D.dullyellow (D.fromChars "\"!\"")) + ] + , D.reflow "The top line (called a \"type annotation\") is optional. You can leave it off if you want. As you get more comfortable with Elm and as your project grows, it becomes more and more valuable to add them though! They work great as compiler-verified documentation, and they often improve error messages!" + ] + + +toLetDestructReport : SyntaxVersion -> Code.Source -> Destruct -> Row -> Col -> Report.Report +toLetDestructReport syntaxVersion source destruct startRow startCol = + case destruct of + DestructSpace space row col -> + toSpaceReport source space row col + + DestructPattern pattern row col -> + toPatternReport syntaxVersion source PLet pattern row col + + DestructEquals row col -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + in + Report.Report "PROBLEM IN DEFINITION" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow "I got stuck trying to parse this definition:" + , case Code.whatIsNext source row col of + Code.Operator ":" -> + D.stack + [ D.reflow "I was expecting to see an equals sign next, followed by an expression telling me what to compute." + , D.toSimpleNote "It looks like you may be trying to write a type annotation? It is not possible to add type annotations on destructuring definitions like this. You can assign a name to the overall structure, put a type annotation on that, and then destructure separately though." + ] + + _ -> + D.reflow "I was expecting to see an equals sign next, followed by an expression telling me what to compute." + ) + + DestructBody expr row col -> + toExprReport syntaxVersion source (InDestruct startRow startCol) expr row col + + DestructIndentEquals row col -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + in + Report.Report "UNFINISHED DEFINITION" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow "I got stuck trying to parse this definition:" + , D.reflow "I was expecting to see an equals sign next, followed by an expression telling me what to compute." + ) + + DestructIndentBody row col -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + in + Report.Report "UNFINISHED DEFINITION" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow "I got stuck while parsing this definition:" + , D.reflow "I was expecting to see an expression next. What is it equal to?" + ) + + + +-- CASE + + +toCaseReport : SyntaxVersion -> Code.Source -> Context -> Case -> Row -> Col -> Report.Report +toCaseReport syntaxVersion source context case_ startRow startCol = + case case_ of + CaseSpace space row col -> + toSpaceReport source space row col + + CaseOf row col -> + toUnfinishCaseReport source + row + col + startRow + startCol + (D.fillSep + [ D.fromChars "I" + , D.fromChars "was" + , D.fromChars "expecting" + , D.fromChars "to" + , D.fromChars "see" + , D.fromChars "the" + , D.dullyellow <| D.fromChars "of" + , D.fromChars "keyword" + , D.fromChars "next." + ] + ) + + CasePattern pattern row col -> + toPatternReport syntaxVersion source PCase pattern row col + + CaseArrow row col -> + case Code.whatIsNext source row col of + Code.Keyword keyword -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toKeywordRegion row col keyword + in + Report.Report "RESERVED WORD" region [] <| + (Code.toSnippet source surroundings (Just region) <| + ( D.reflow "I am partway through parsing a `case` expression, but I got stuck here:" + , D.reflow ("It looks like you are trying to use `" ++ keyword ++ "` in one of your patterns, but it is a reserved word. Try using a different name?") + ) + ) + + Code.Operator ":" -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + in + Report.Report "UNEXPECTED OPERATOR" region [] <| + (Code.toSnippet source surroundings (Just region) <| + ( D.reflow "I am partway through parsing a `case` expression, but I got stuck here:" + , D.fillSep + [ D.fromChars "I" + , D.fromChars "am" + , D.fromChars "seeing" + , D.dullyellow <| D.fromChars ":" + , D.fromChars "but" + , D.fromChars "maybe" + , D.fromChars "you" + , D.fromChars "want" + , D.green <| D.fromChars "::" + , D.fromChars "instead?" + , D.fromChars "For" + , D.fromChars "pattern" + , D.fromChars "matching" + , D.fromChars "on" + , D.fromChars "lists?" + ] + ) + ) + + Code.Operator "=" -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + in + Report.Report "UNEXPECTED OPERATOR" region [] <| + (Code.toSnippet source surroundings (Just region) <| + ( D.reflow "I am partway through parsing a `case` expression, but I got stuck here:" + , D.fillSep + [ D.fromChars "I" + , D.fromChars "am" + , D.fromChars "seeing" + , D.dullyellow <| D.fromChars "=" + , D.fromChars "but" + , D.fromChars "maybe" + , D.fromChars "you" + , D.fromChars "want" + , D.green <| D.fromChars "->" + , D.fromChars "instead?" + ] + ) + ) + + _ -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + in + Report.Report "MISSING ARROW" region [] <| + (Code.toSnippet source surroundings (Just region) <| + ( D.reflow "I am partway through parsing a `case` expression, but I got stuck here:" + , D.stack + [ D.reflow "I was expecting to see an arrow next." + , noteForCaseIndentError + ] + ) + ) + + CaseExpr expr row col -> + toExprReport syntaxVersion source (InNode NCase startRow startCol context) expr row col + + CaseBranch expr row col -> + toExprReport syntaxVersion source (InNode NBranch startRow startCol context) expr row col + + CaseIndentOf row col -> + toUnfinishCaseReport source + row + col + startRow + startCol + (D.fillSep + [ D.fromChars "I" + , D.fromChars "was" + , D.fromChars "expecting" + , D.fromChars "to" + , D.fromChars "see" + , D.fromChars "the" + , D.dullyellow <| D.fromChars "of" + , D.fromChars "keyword" + , D.fromChars "next." + ] + ) + + CaseIndentExpr row col -> + toUnfinishCaseReport source + row + col + startRow + startCol + (D.reflow "I was expecting to see an expression next.") + + CaseIndentPattern row col -> + toUnfinishCaseReport source + row + col + startRow + startCol + (D.reflow "I was expecting to see a pattern next.") + + CaseIndentArrow row col -> + toUnfinishCaseReport source + row + col + startRow + startCol + (D.fillSep + [ D.fromChars "I" + , D.fromChars "just" + , D.fromChars "saw" + , D.fromChars "a" + , D.fromChars "pattern," + , D.fromChars "so" + , D.fromChars "I" + , D.fromChars "was" + , D.fromChars "expecting" + , D.fromChars "to" + , D.fromChars "see" + , D.fromChars "a" + , D.dullyellow <| D.fromChars "->" + , D.fromChars "next." + ] + ) + + CaseIndentBranch row col -> + toUnfinishCaseReport source + row + col + startRow + startCol + (D.reflow "I was expecting to see an expression next. What should I do when I run into this particular pattern?") + + CasePatternAlignment indent row col -> + toUnfinishCaseReport source + row + col + startRow + startCol + (D.reflow ("I suspect this is a pattern that is not indented far enough? (" ++ String.fromInt indent ++ " spaces)")) + + +toUnfinishCaseReport : Code.Source -> Int -> Int -> Int -> Int -> D.Doc -> Report.Report +toUnfinishCaseReport source row col startRow startCol message = + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + in + Report.Report "UNFINISHED CASE" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow "I was partway through parsing a `case` expression, but I got stuck here:" + , D.stack + [ message + , noteForCaseError + ] + ) + + +noteForCaseError : D.Doc +noteForCaseError = + D.stack + [ D.toSimpleNote "Here is an example of a valid `case` expression for reference." + , D.vcat + [ D.indent 4 (D.fillSep [ D.cyan (D.fromChars "case"), D.fromChars "maybeWidth", D.cyan (D.fromChars "of") ]) + , D.indent 6 (D.fillSep [ D.blue (D.fromChars "Just"), D.fromChars "width", D.fromChars "->" ]) + , D.indent 8 (D.fillSep [ D.fromChars "width", D.fromChars "+", D.dullyellow (D.fromChars "200") ]) + , D.fromChars "" + , D.indent 6 (D.fillSep [ D.blue (D.fromChars "Nothing"), D.fromChars "->" ]) + , D.indent 8 (D.fillSep [ D.dullyellow (D.fromChars "400") ]) + ] + , D.reflow "Notice the indentation. Each pattern is aligned, and each branch is indented a bit more than the corresponding pattern. That is important!" + ] + + +noteForCaseIndentError : D.Doc +noteForCaseIndentError = + D.stack + [ D.toSimpleNote "Sometimes I get confused by indentation, so try to make your `case` look something like this:" + , D.vcat + [ D.indent 4 (D.fillSep [ D.cyan (D.fromChars "case"), D.fromChars "maybeWidth", D.cyan (D.fromChars "of") ]) + , D.indent 6 (D.fillSep [ D.blue (D.fromChars "Just"), D.fromChars "width", D.fromChars "->" ]) + , D.indent 8 (D.fillSep [ D.fromChars "width", D.fromChars "+", D.dullyellow (D.fromChars "200") ]) + , D.fromChars "" + , D.indent 6 (D.fillSep [ D.blue (D.fromChars "Nothing"), D.fromChars "->" ]) + , D.indent 8 (D.fillSep [ D.dullyellow (D.fromChars "400") ]) + ] + , D.reflow "Notice the indentation! Patterns are aligned with each other. Same indentation. The expressions after each arrow are all indented a bit more than the patterns. That is important!" + ] + + + +-- IF + + +toIfReport : SyntaxVersion -> Code.Source -> Context -> If -> Row -> Col -> Report.Report +toIfReport syntaxVersion source context if_ startRow startCol = + case if_ of + IfSpace space row col -> + toSpaceReport source space row col + + IfThen row col -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + in + Report.Report "UNFINISHED IF" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow "I was expecting to see more of this `if` expression, but I got stuck here:" + , D.fillSep + [ D.fromChars "I" + , D.fromChars "was" + , D.fromChars "expecting" + , D.fromChars "to" + , D.fromChars "see" + , D.fromChars "the" + , D.cyan <| D.fromChars "then" + , D.fromChars "keyword" + , D.fromChars "next." + ] + ) + + IfElse row col -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + in + Report.Report "UNFINISHED IF" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow "I was expecting to see more of this `if` expression, but I got stuck here:" + , D.fillSep + [ D.fromChars "I" + , D.fromChars "was" + , D.fromChars "expecting" + , D.fromChars "to" + , D.fromChars "see" + , D.fromChars "the" + , D.cyan <| D.fromChars "else" + , D.fromChars "keyword" + , D.fromChars "next." + ] + ) + + IfElseBranchStart row col -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + in + Report.Report "UNFINISHED IF" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow "I just saw the start of an `else` branch, but then I got stuck here:" + , D.reflow "I was expecting to see an expression next. Maybe it is not filled in yet?" + ) + + IfCondition expr row col -> + toExprReport syntaxVersion source (InNode NCond startRow startCol context) expr row col + + IfThenBranch expr row col -> + toExprReport syntaxVersion source (InNode NThen startRow startCol context) expr row col + + IfElseBranch expr row col -> + toExprReport syntaxVersion source (InNode NElse startRow startCol context) expr row col + + IfIndentCondition row col -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + in + Report.Report "UNFINISHED IF" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow "I was expecting to see more of this `if` expression, but I got stuck here:" + , D.stack + [ D.fillSep + [ D.fromChars "I" + , D.fromChars "was" + , D.fromChars "expecting" + , D.fromChars "to" + , D.fromChars "see" + , D.fromChars "an" + , D.fromChars "expression" + , D.fromChars "like" + , D.dullyellow <| D.fromChars "x < 0" + , D.fromChars "that" + , D.fromChars "evaluates" + , D.fromChars "to" + , D.fromChars "True" + , D.fromChars "or" + , D.fromChars "False." + ] + , D.toSimpleNote "I can be confused by indentation. Maybe something is not indented enough?" + ] + ) + + IfIndentThen row col -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + in + Report.Report "UNFINISHED IF" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow "I was expecting to see more of this `if` expression, but I got stuck here:" + , D.stack + [ D.fillSep + [ D.fromChars "I" + , D.fromChars "was" + , D.fromChars "expecting" + , D.fromChars "to" + , D.fromChars "see" + , D.fromChars "the" + , D.cyan <| D.fromChars "then" + , D.fromChars "keyword" + , D.fromChars "next." + ] + , D.toSimpleNote "I can be confused by indentation. Maybe something is not indented enough?" + ] + ) + + IfIndentThenBranch row col -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + in + Report.Report "UNFINISHED IF" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow "I got stuck after the start of this `then` branch:" + , D.stack + [ D.reflow "I was expecting to see an expression next. Maybe it is not filled in yet?" + , D.toSimpleNote "I can be confused by indentation, so if the `then` branch is already present, it may not be indented enough for me to recognize it." + ] + ) + + IfIndentElseBranch row col -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + in + Report.Report "UNFINISHED IF" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow "I got stuck after the start of this `else` branch:" + , D.stack + [ D.reflow "I was expecting to see an expression next. Maybe it is not filled in yet?" + , D.toSimpleNote "I can be confused by indentation, so if the `else` branch is already present, it may not be indented enough for me to recognize it." + ] + ) + + IfIndentElse row col -> + case Code.nextLineStartsWithKeyword "else" source row of + Just ( elseRow, elseCol ) -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position elseRow elseCol) + + region : A.Region + region = + toWiderRegion elseRow elseCol 4 + in + Report.Report "WEIRD ELSE BRANCH" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow "I was partway through an `if` expression when I got stuck here:" + , D.fillSep + [ D.fromChars "I" + , D.fromChars "think" + , D.fromChars "this" + , D.cyan <| D.fromChars "else" + , D.fromChars "keyword" + , D.fromChars "needs" + , D.fromChars "to" + , D.fromChars "be" + , D.fromChars "indented" + , D.fromChars "more." + , D.fromChars "Try" + , D.fromChars "adding" + , D.fromChars "some" + , D.fromChars "spaces" + , D.fromChars "before" + , D.fromChars "it." + ] + ) + + Nothing -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + in + Report.Report "UNFINISHED IF" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow "I was expecting to see an `else` branch after this:" + , D.stack + [ D.fillSep + [ D.fromChars "I" + , D.fromChars "know" + , D.fromChars "what" + , D.fromChars "to" + , D.fromChars "do" + , D.fromChars "when" + , D.fromChars "the" + , D.fromChars "condition" + , D.fromChars "is" + , D.fromChars "True," + , D.fromChars "but" + , D.fromChars "what" + , D.fromChars "happens" + , D.fromChars "when" + , D.fromChars "it" + , D.fromChars "is" + , D.fromChars "False?" + , D.fromChars "Add" + , D.fromChars "an" + , D.cyan <| D.fromChars "else" + , D.fromChars "branch" + , D.fromChars "to" + , D.fromChars "handle" + , D.fromChars "that" + , D.fromChars "scenario!" + ] + ] + ) + + + +-- RECORD + + +toRecordReport : SyntaxVersion -> Code.Source -> Context -> Record -> Row -> Col -> Report.Report +toRecordReport syntaxVersion source context record startRow startCol = + case record of + RecordOpen row col -> + case Code.whatIsNext source row col of + Code.Keyword keyword -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toKeywordRegion row col keyword + in + Report.Report "RESERVED WORD" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow "I just started parsing a record, but I got stuck on this field name:" + , D.reflow <| + ("It looks like you are trying to use `" ++ keyword ++ "` as a field name, but that is a reserved word. Try using a different name!") + ) + + _ -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + in + Report.Report "PROBLEM IN RECORD" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow "I just started parsing a record, but I got stuck here:" + , D.stack + [ D.fillSep + [ D.fromChars "I" + , D.fromChars "was" + , D.fromChars "expecting" + , D.fromChars "to" + , D.fromChars "see" + , D.fromChars "a" + , D.fromChars "record" + , D.fromChars "field" + , D.fromChars "defined" + , D.fromChars "next," + , D.fromChars "so" + , D.fromChars "I" + , D.fromChars "am" + , D.fromChars "looking" + , D.fromChars "for" + , D.fromChars "a" + , D.fromChars "name" + , D.fromChars "like" + , D.dullyellow (D.fromChars "userName") + , D.fromChars "or" + , D.dullyellow (D.fromChars "plantHeight") + |> D.a (D.fromChars ".") + ] + , D.toSimpleNote "Field names must start with a lower-case letter. After that, you can use any sequence of letters, numbers, and underscores." + , noteForRecordError + ] + ) + + RecordEnd row col -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + in + Report.Report "PROBLEM IN RECORD" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow "I am partway through parsing a record, but I got stuck here:" + , D.stack + [ D.fillSep + [ D.fromChars "I" + , D.fromChars "was" + , D.fromChars "expecting" + , D.fromChars "to" + , D.fromChars "see" + , D.fromChars "a" + , D.fromChars "closing" + , D.fromChars "curly" + , D.fromChars "brace" + , D.fromChars "before" + , D.fromChars "this," + , D.fromChars "so" + , D.fromChars "try" + , D.fromChars "adding" + , D.fromChars "a" + , D.dullyellow <| D.fromChars "}" + , D.fromChars "and" + , D.fromChars "see" + , D.fromChars "if" + , D.fromChars "that" + , D.fromChars "helps?" + ] + , D.toSimpleNote "When I get stuck like this, it usually means that there is a missing parenthesis or bracket somewhere earlier. It could also be a stray keyword or operator." + ] + ) + + RecordField row col -> + case Code.whatIsNext source row col of + Code.Keyword keyword -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toKeywordRegion row col keyword + in + Report.Report "RESERVED WORD" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow "I am partway through parsing a record, but I got stuck on this field name:" + , D.reflow <| ("It looks like you are trying to use `" ++ keyword ++ "` as a field name, but that is a reserved word. Try using a different name!") + ) + + Code.Other (Just ',') -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + in + Report.Report "EXTRA COMMA" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow "I am partway through parsing a record, but I got stuck here:" + , D.stack + [ D.reflow "I am seeing two commas in a row. This is the second one!" + , D.reflow "Just delete one of the commas and you should be all set!" + , noteForRecordError + ] + ) + + Code.Close _ '}' -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + in + Report.Report "EXTRA COMMA" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow "I am partway through parsing a record, but I got stuck here:" + , D.stack + [ D.reflow "Trailing commas are not allowed in records. Try deleting the comma that appears before this closing curly brace." + , noteForRecordError + ] + ) + + _ -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + in + Report.Report "PROBLEM IN RECORD" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow "I am partway through parsing a record, but I got stuck here:" + , D.stack + [ D.fillSep + [ D.fromChars "I" + , D.fromChars "was" + , D.fromChars "expecting" + , D.fromChars "to" + , D.fromChars "see" + , D.fromChars "another" + , D.fromChars "record" + , D.fromChars "field" + , D.fromChars "defined" + , D.fromChars "next," + , D.fromChars "so" + , D.fromChars "I" + , D.fromChars "am" + , D.fromChars "looking" + , D.fromChars "for" + , D.fromChars "a" + , D.fromChars "name" + , D.fromChars "like" + , D.dullyellow (D.fromChars "userName") + , D.fromChars "or" + , D.dullyellow (D.fromChars "plantHeight") + |> D.a (D.fromChars ".") + ] + , D.toSimpleNote "Field names must start with a lower-case letter. After that, you can use any sequence of letters, numbers, and underscores." + , noteForRecordError + ] + ) + + RecordEquals row col -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + in + Report.Report "PROBLEM IN RECORD" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow "I am partway through parsing a record, but I got stuck here:" + , D.stack + [ D.fillSep + [ D.fromChars "I" + , D.fromChars "just" + , D.fromChars "saw" + , D.fromChars "a" + , D.fromChars "field" + , D.fromChars "name," + , D.fromChars "so" + , D.fromChars "I" + , D.fromChars "was" + , D.fromChars "expecting" + , D.fromChars "to" + , D.fromChars "see" + , D.fromChars "an" + , D.fromChars "equals" + , D.fromChars "sign" + , D.fromChars "next." + , D.fromChars "So" + , D.fromChars "try" + , D.fromChars "putting" + , D.fromChars "an" + , D.green <| D.fromChars "=" + , D.fromChars "sign" + , D.fromChars "here?" + ] + , noteForRecordError + ] + ) + + RecordExpr expr row col -> + toExprReport syntaxVersion source (InNode NRecord startRow startCol context) expr row col + + RecordSpace space row col -> + toSpaceReport source space row col + + RecordIndentOpen row col -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + in + Report.Report "UNFINISHED RECORD" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow "I just saw the opening curly brace of a record, but then I got stuck here:" + , D.stack + [ D.fillSep + [ D.fromChars "I" + , D.fromChars "am" + , D.fromChars "expecting" + , D.fromChars "a" + , D.fromChars "record" + , D.fromChars "like" + , D.dullyellow <| D.fromChars "{ x = 3, y = 4 }" + , D.fromChars "here." + , D.fromChars "Try" + , D.fromChars "defining" + , D.fromChars "some" + , D.fromChars "fields" + , D.fromChars "of" + , D.fromChars "your" + , D.fromChars "own?" + ] + , noteForRecordIndentError + ] + ) + + RecordIndentEnd row col -> + case Code.nextLineStartsWithCloseCurly source row of + Just ( curlyRow, curlyCol ) -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position curlyRow curlyCol) + + region : A.Region + region = + toRegion curlyRow curlyCol + in + Report.Report "NEED MORE INDENTATION" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow "I was partway through parsing a record, but I got stuck here:" + , D.stack + [ D.reflow "I need this curly brace to be indented more. Try adding some spaces before it!" + , noteForRecordError + ] + ) + + Nothing -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + in + Report.Report "UNFINISHED RECORD" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow "I was partway through parsing a record, but I got stuck here:" + , D.stack + [ D.fillSep + [ D.fromChars "I" + , D.fromChars "was" + , D.fromChars "expecting" + , D.fromChars "to" + , D.fromChars "see" + , D.fromChars "a" + , D.fromChars "closing" + , D.fromChars "curly" + , D.fromChars "brace" + , D.fromChars "next." + , D.fromChars "Try" + , D.fromChars "putting" + , D.fromChars "a" + , D.green <| D.fromChars "}" + , D.fromChars "next" + , D.fromChars "and" + , D.fromChars "see" + , D.fromChars "if" + , D.fromChars "that" + , D.fromChars "helps?" + ] + , noteForRecordIndentError + ] + ) + + RecordIndentField row col -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + in + Report.Report "UNFINISHED RECORD" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow "I am partway through parsing a record, but I got stuck after that last comma:" + , D.stack + [ D.reflow "Trailing commas are not allowed in records, so the fix may be to delete that last comma? Or maybe you were in the middle of defining an additional field?" + , noteForRecordError + ] + ) + + RecordIndentEquals row col -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + in + Report.Report "UNFINISHED RECORD" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow "I am partway through parsing a record. I just saw a record field, so I was expecting to see an equals sign next:" + , D.stack + [ D.fillSep + [ D.fromChars "Try" + , D.fromChars "putting" + , D.fromChars "an" + , D.green <| D.fromChars "=" + , D.fromChars "followed" + , D.fromChars "by" + , D.fromChars "an" + , D.fromChars "expression?" + ] + , noteForRecordIndentError + ] + ) + + RecordIndentExpr row col -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + in + Report.Report "UNFINISHED RECORD" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow "I am partway through parsing a record, and I was expecting to run into an expression next:" + , D.stack + [ D.fillSep + [ D.fromChars "Try" + , D.fromChars "putting" + , D.fromChars "something" + , D.fromChars "like" + , D.dullyellow <| D.fromChars "42" + , D.fromChars "or" + , D.dullyellow <| D.fromChars "\"hello\"" + , D.fromChars "for" + , D.fromChars "now?" + ] + , noteForRecordIndentError + ] + ) + + +noteForRecordError : D.Doc +noteForRecordError = + D.stack + [ D.toSimpleNote "If you are trying to define a record across multiple lines, I recommend using this format:" + , D.indent 4 <| + D.vcat + [ D.fromChars "{ name = " |> D.a (D.dullyellow (D.fromChars "\"Alice\"")) + , D.fromChars ", age = " |> D.a (D.dullyellow (D.fromChars "42")) + , D.fromChars ", height = " |> D.a (D.dullyellow (D.fromChars "1.75")) + , D.fromChars "}" + ] + , D.reflow "Notice that each line starts with some indentation. Usually two or four spaces. This is the stylistic convention in the Elm ecosystem." + ] + + +noteForRecordIndentError : D.Doc +noteForRecordIndentError = + D.stack + [ D.toSimpleNote "I may be confused by indentation. For example, if you are trying to define a record across multiple lines, I recommend using this format:" + , D.indent 4 <| + D.vcat + [ D.fromChars "{ name = " |> D.a (D.dullyellow (D.fromChars "\"Alice\"")) + , D.fromChars ", age = " |> D.a (D.dullyellow (D.fromChars "42")) + , D.fromChars ", height = " |> D.a (D.dullyellow (D.fromChars "1.75")) + , D.fromChars "}" + ] + , D.reflow "Notice that each line starts with some indentation. Usually two or four spaces. This is the stylistic convention in the Elm ecosystem!" + ] + + + +-- TUPLE + + +toTupleReport : SyntaxVersion -> Code.Source -> Context -> Tuple -> Row -> Col -> Report.Report +toTupleReport syntaxVersion source context tuple startRow startCol = + case tuple of + TupleExpr expr row col -> + toExprReport syntaxVersion source (InNode NParens startRow startCol context) expr row col + + TupleSpace space row col -> + toSpaceReport source space row col + + TupleEnd row col -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + in + Report.Report "UNFINISHED PARENTHESES" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow "I was expecting to see a closing parentheses next, but I got stuck here:" + , D.stack + [ D.fillSep + [ D.fromChars "Try" + , D.fromChars "adding" + , D.fromChars "a" + , D.dullyellow <| D.fromChars ")" + , D.fromChars "to" + , D.fromChars "see" + , D.fromChars "if" + , D.fromChars "that" + , D.fromChars "helps?" + ] + , D.toSimpleNote "I can get stuck when I run into keywords, operators, parentheses, or brackets unexpectedly. So there may be some earlier syntax trouble (like extra parenthesis or missing brackets) that is confusing me." + ] + ) + + TupleOperatorClose row col -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + in + Report.Report "UNFINISHED OPERATOR FUNCTION" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow "I was expecting a closing parenthesis here:" + , D.stack + [ D.fillSep + [ D.fromChars "Try" + , D.fromChars "adding" + , D.fromChars "a" + , D.dullyellow <| D.fromChars ")" + , D.fromChars "to" + , D.fromChars "see" + , D.fromChars "if" + , D.fromChars "that" + , D.fromChars "helps!" + ] + , D.toSimpleNote "I think I am parsing an operator function right now, so I am expecting to see something like (+) or (&&) where an operator is surrounded by parentheses with no extra spaces." + ] + ) + + TupleOperatorReserved operator row col -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + in + Report.Report "UNEXPECTED SYMBOL" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow "I ran into an unexpected symbol here:" + , D.fillSep + (case operator of + BadDot -> + [ D.fromChars "Maybe" + , D.fromChars "you" + , D.fromChars "wanted" + , D.fromChars "a" + , D.fromChars "record" + , D.fromChars "accessor" + , D.fromChars "like" + , D.dullyellow <| D.fromChars ".x" + , D.fromChars "or" + , D.dullyellow <| D.fromChars ".name" + , D.fromChars "instead?" + ] + + BadPipe -> + [ D.fromChars "Try" + , D.dullyellow <| D.fromChars "(||)" + , D.fromChars "instead?" + , D.fromChars "To" + , D.fromChars "turn" + , D.fromChars "boolean" + , D.fromChars "OR" + , D.fromChars "into" + , D.fromChars "a" + , D.fromChars "function?" + ] + + BadArrow -> + [ D.fromChars "Maybe" + , D.fromChars "you" + , D.fromChars "wanted" + , D.dullyellow <| D.fromChars "(>)" + , D.fromChars "or" + , D.dullyellow <| D.fromChars "(>=)" + , D.fromChars "instead?" + ] + + BadEquals -> + [ D.fromChars "Try" + , D.dullyellow <| D.fromChars "(==)" + , D.fromChars "instead?" + , D.fromChars "To" + , D.fromChars "make" + , D.fromChars "a" + , D.fromChars "function" + , D.fromChars "that" + , D.fromChars "checks" + , D.fromChars "equality?" + ] + + BadHasType -> + [ D.fromChars "Try" + , D.dullyellow <| D.fromChars "(::)" + , D.fromChars "instead?" + , D.fromChars "To" + , D.fromChars "add" + , D.fromChars "values" + , D.fromChars "to" + , D.fromChars "the" + , D.fromChars "front" + , D.fromChars "of" + , D.fromChars "lists?" + ] + ) + ) + + TupleIndentExpr1 row col -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + in + Report.Report "UNFINISHED PARENTHESES" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow "I just saw an open parenthesis, so I was expecting to see an expression next." + , D.stack + [ D.fillSep + [ D.fromChars "Something" + , D.fromChars "like" + , D.dullyellow <| D.fromChars "(4 + 5)" + , D.fromChars "or" + , D.dullyellow <| D.fromChars "(String.reverse \"desserts\")" + , D.fromChars "." + , D.fromChars "Anything" + , D.fromChars "where" + , D.fromChars "you" + , D.fromChars "are" + , D.fromChars "putting" + , D.fromChars "parentheses" + , D.fromChars "around" + , D.fromChars "normal" + , D.fromChars "expressions." + ] + , D.toSimpleNote "I can get confused by indentation in cases like this, so maybe you have an expression but it is not indented enough?" + ] + ) + + TupleIndentExprN row col -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + in + Report.Report "UNFINISHED TUPLE" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow "I think I am in the middle of parsing a tuple. I just saw a comma, so I was expecting to see an expression next." + , D.stack + [ D.fillSep + [ D.fromChars "A" + , D.fromChars "tuple" + , D.fromChars "looks" + , D.fromChars "like" + , D.dullyellow <| D.fromChars "(3,4)" + , D.fromChars "or" + , D.dullyellow <| D.fromChars "(\"Tom\",42)" + , D.fromChars "," + , D.fromChars "so" + , D.fromChars "I" + , D.fromChars "think" + , D.fromChars "there" + , D.fromChars "is" + , D.fromChars "an" + , D.fromChars "expression" + , D.fromChars "missing" + , D.fromChars "here?" + ] + , D.toSimpleNote "I can get confused by indentation in cases like this, so maybe you have an expression but it is not indented enough?" + ] + ) + + TupleIndentEnd row col -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + in + Report.Report "UNFINISHED PARENTHESES" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow "I was expecting to see a closing parenthesis next:" + , D.stack + [ D.fillSep + [ D.fromChars "Try" + , D.fromChars "adding" + , D.fromChars "a" + , D.dullyellow <| D.fromChars ")" + , D.fromChars "to" + , D.fromChars "see" + , D.fromChars "if" + , D.fromChars "that" + , D.fromChars "helps!" + ] + , D.toSimpleNote "I can get confused by indentation in cases like this, so maybe you have a closing parenthesis but it is not indented enough?" + ] + ) + + +toListReport : SyntaxVersion -> Code.Source -> Context -> List_ -> Row -> Col -> Report.Report +toListReport syntaxVersion source context list startRow startCol = + case list of + ListSpace space row col -> + toSpaceReport source space row col + + ListOpen row col -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + in + Report.Report "UNFINISHED LIST" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow "I am partway through parsing a list, but I got stuck here:" + , D.stack + [ D.fillSep + [ D.fromChars "I" + , D.fromChars "was" + , D.fromChars "expecting" + , D.fromChars "to" + , D.fromChars "see" + , D.fromChars "a" + , D.fromChars "closing" + , D.fromChars "square" + , D.fromChars "bracket" + , D.fromChars "before" + , D.fromChars "this," + , D.fromChars "so" + , D.fromChars "try" + , D.fromChars "adding" + , D.fromChars "a" + , D.dullyellow <| D.fromChars "]" + , D.fromChars "and" + , D.fromChars "see" + , D.fromChars "if" + , D.fromChars "that" + , D.fromChars "helps?" + ] + , D.toSimpleNote + "When I get stuck like this, it usually means that there is a missing parenthesis or bracket somewhere earlier. It could also be a stray keyword or operator." + ] + ) + + ListExpr expr row col -> + case expr of + Start r c -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position r c) + + region : A.Region + region = + toRegion r c + in + Report.Report "UNFINISHED LIST" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow "I was expecting to see another list entry after that last comma:" + , D.stack + [ D.reflow "Trailing commas are not allowed in lists, so the fix may be to delete the comma?" + , D.toSimpleNote "I recommend using the following format for lists that span multiple lines:" + , D.indent 4 <| + D.vcat + [ D.fromChars "[ " |> D.a (D.dullyellow (D.fromChars "\"Alice\"")) + , D.fromChars ", " |> D.a (D.dullyellow (D.fromChars "\"Bob\"")) + , D.fromChars ", " |> D.a (D.dullyellow (D.fromChars "\"Chuck\"")) + , D.fromChars "]" + ] + , D.reflow "Notice that each line starts with some indentation. Usually two or four spaces. This is the stylistic convention in the Elm ecosystem." + ] + ) + + _ -> + toExprReport syntaxVersion source (InNode NList startRow startCol context) expr row col + + ListEnd row col -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + in + Report.Report "UNFINISHED LIST" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow "I am partway through parsing a list, but I got stuck here:" + , D.stack + [ D.fillSep + [ D.fromChars "I" + , D.fromChars "was" + , D.fromChars "expecting" + , D.fromChars "to" + , D.fromChars "see" + , D.fromChars "a" + , D.fromChars "closing" + , D.fromChars "square" + , D.fromChars "bracket" + , D.fromChars "before" + , D.fromChars "this," + , D.fromChars "so" + , D.fromChars "try" + , D.fromChars "adding" + , D.fromChars "a" + , D.dullyellow <| D.fromChars "]" + , D.fromChars "and" + , D.fromChars "see" + , D.fromChars "if" + , D.fromChars "that" + , D.fromChars "helps?" + ] + , D.toSimpleNote + "When I get stuck like this, it usually means that there is a missing parenthesis or bracket somewhere earlier. It could also be a stray keyword or operator." + ] + ) + + ListIndentOpen row col -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + in + Report.Report "UNFINISHED LIST" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow "I cannot find the end of this list:" + , D.stack + [ D.fillSep + [ D.fromChars "You" + , D.fromChars "could" + , D.fromChars "change" + , D.fromChars "it" + , D.fromChars "to" + , D.fromChars "something" + , D.fromChars "like" + , D.dullyellow <| D.fromChars "[3,4,5]" + , D.fromChars "or" + , D.fromChars "even" + , D.fromChars "just" + , D.dullyellow <| D.fromChars "[]" + , D.fromChars "." + , D.fromChars "Anything" + , D.fromChars "where" + , D.fromChars "there" + , D.fromChars "is" + , D.fromChars "an" + , D.fromChars "open" + , D.fromChars "and" + , D.fromChars "close" + , D.fromChars "square" + , D.fromChars "brace," + , D.fromChars "and" + , D.fromChars "where" + , D.fromChars "the" + , D.fromChars "elements" + , D.fromChars "of" + , D.fromChars "the" + , D.fromChars "list" + , D.fromChars "are" + , D.fromChars "separated" + , D.fromChars "by" + , D.fromChars "commas." + ] + , D.toSimpleNote + "I may be confused by indentation. For example, if you are trying to define a list across multiple lines, I recommend using this format:" + , D.indent 4 <| + D.vcat + [ D.fromChars "[ " |> D.a (D.dullyellow (D.fromChars "\"Alice\"")) + , D.fromChars ", " |> D.a (D.dullyellow (D.fromChars "\"Bob\"")) + , D.fromChars ", " |> D.a (D.dullyellow (D.fromChars "\"Chuck\"")) + , D.fromChars "]" + ] + , D.reflow "Notice that each line starts with some indentation. Usually two or four spaces. This is the stylistic convention in the Elm ecosystem." + ] + ) + + ListIndentEnd row col -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + in + Report.Report "UNFINISHED LIST" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow "I cannot find the end of this list:" + , D.stack + [ D.fillSep + [ D.fromChars "You" + , D.fromChars "can" + , D.fromChars "just" + , D.fromChars "add" + , D.fromChars "a" + , D.fromChars "closing" + , D.dullyellow <| D.fromChars "]" + , D.fromChars "right" + , D.fromChars "here," + , D.fromChars "and" + , D.fromChars "I" + , D.fromChars "will" + , D.fromChars "be" + , D.fromChars "all" + , D.fromChars "set!" + ] + , D.toSimpleNote + "I may be confused by indentation. For example, if you are trying to define a list across multiple lines, I recommend using this format:" + , D.indent 4 <| + D.vcat + [ D.fromChars "[ " |> D.a (D.dullyellow (D.fromChars "\"Alice\"")) + , D.fromChars ", " |> D.a (D.dullyellow (D.fromChars "\"Bob\"")) + , D.fromChars ", " |> D.a (D.dullyellow (D.fromChars "\"Chuck\"")) + , D.fromChars "]" + ] + , D.reflow "Notice that each line starts with some indentation. Usually two or four spaces. This is the stylistic convention in the Elm ecosystem." + ] + ) + + ListIndentExpr row col -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + in + Report.Report "UNFINISHED LIST" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow "I was expecting to see another list entry after this comma:" + , D.stack + [ D.reflow "Trailing commas are not allowed in lists, so the fix may be to delete the comma?" + , D.toSimpleNote "I recommend using the following format for lists that span multiple lines:" + , D.indent 4 <| + D.vcat + [ D.fromChars "[ " |> D.a (D.dullyellow (D.fromChars "\"Alice\"")) + , D.fromChars ", " |> D.a (D.dullyellow (D.fromChars "\"Bob\"")) + , D.fromChars ", " |> D.a (D.dullyellow (D.fromChars "\"Chuck\"")) + , D.fromChars "]" + ] + , D.reflow "Notice that each line starts with some indentation. Usually two or four spaces. This is the stylistic convention in the Elm ecosystem." + ] + ) + + +toFuncReport : SyntaxVersion -> Code.Source -> Context -> Func -> Row -> Col -> Report.Report +toFuncReport syntaxVersion source context func startRow startCol = + case func of + FuncSpace space row col -> + toSpaceReport source space row col + + FuncArg pattern row col -> + toPatternReport syntaxVersion source PArg pattern row col + + FuncBody expr row col -> + toExprReport syntaxVersion source (InNode NFunc startRow startCol context) expr row col + + FuncArrow row col -> + case Code.whatIsNext source row col of + Code.Keyword keyword -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toKeywordRegion row col keyword + in + Report.Report "RESERVED WORD" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow "I was parsing an anonymous function, but I got stuck here:" + , D.reflow ("It looks like you are trying to use `" ++ keyword ++ "` as an argument, but it is a reserved word in this language. Try using a different argument name!") + ) + + _ -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + in + Report.Report "UNFINISHED ANONYMOUS FUNCTION" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow "I just saw the beginning of an anonymous function, so I was expecting to see an arrow next:" + , D.fillSep + [ D.fromChars "The" + , D.fromChars "syntax" + , D.fromChars "for" + , D.fromChars "anonymous" + , D.fromChars "functions" + , D.fromChars "is" + , D.dullyellow <| D.fromChars "(\\x -> x + 1)" + , D.fromChars "so" + , D.fromChars "I" + , D.fromChars "am" + , D.fromChars "missing" + , D.fromChars "the" + , D.fromChars "arrow" + , D.fromChars "and" + , D.fromChars "the" + , D.fromChars "body" + , D.fromChars "of" + , D.fromChars "the" + , D.fromChars "function." + ] + ) + + FuncIndentArg row col -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + in + Report.Report "MISSING ARGUMENT" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow "I just saw the beginning of an anonymous function, so I was expecting to see an argument next:" + , D.stack + [ D.fillSep + [ D.fromChars "Something" + , D.fromChars "like" + , D.dullyellow <| D.fromChars "x" + , D.fromChars "or" + , D.dullyellow (D.fromChars "name") |> D.a (D.fromChars ".") + , D.fromChars "Anything" + , D.fromChars "that" + , D.fromChars "starts" + , D.fromChars "with" + , D.fromChars "a" + , D.fromChars "lower" + , D.fromChars "case" + , D.fromChars "letter!" + ] + , D.toSimpleNote "The syntax for anonymous functions is (\\x -> x + 1) where the backslash is meant to look a bit like a lambda if you squint. This visual pun seemed like a better idea at the time!" + ] + ) + + FuncIndentArrow row col -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + in + Report.Report "UNFINISHED ANONYMOUS FUNCTION" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow "I just saw the beginning of an anonymous function, so I was expecting to see an arrow next:" + , D.stack + [ D.fillSep + [ D.fromChars "The" + , D.fromChars "syntax" + , D.fromChars "for" + , D.fromChars "anonymous" + , D.fromChars "functions" + , D.fromChars "is" + , D.dullyellow <| D.fromChars "(\\x -> x + 1)" + , D.fromChars "so" + , D.fromChars "I" + , D.fromChars "am" + , D.fromChars "missing" + , D.fromChars "the" + , D.fromChars "arrow" + , D.fromChars "and" + , D.fromChars "the" + , D.fromChars "body" + , D.fromChars "of" + , D.fromChars "the" + , D.fromChars "function." + ] + , D.toSimpleNote "It is possible that I am confused about indentation! I generally recommend switching to named functions if the definition cannot fit inline nicely, so either (1) try to fit the whole anonymous function on one line or (2) break the whole thing out into a named function. Things tend to be clearer that way!" + ] + ) + + FuncIndentBody row col -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + in + Report.Report "UNFINISHED ANONYMOUS FUNCTION" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow "I was expecting to see the body of your anonymous function next:" + , D.stack + [ D.fillSep + [ D.fromChars "The" + , D.fromChars "syntax" + , D.fromChars "for" + , D.fromChars "anonymous" + , D.fromChars "functions" + , D.fromChars "is" + , D.dullyellow <| D.fromChars "(\\x -> x + 1)" + , D.fromChars "so" + , D.fromChars "I" + , D.fromChars "am" + , D.fromChars "missing" + , D.fromChars "all" + , D.fromChars "the" + , D.fromChars "stuff" + , D.fromChars "after" + , D.fromChars "the" + , D.fromChars "arrow!" + ] + , D.toSimpleNote "It is possible that I am confused about indentation! I generally recommend switching to named functions if the definition cannot fit inline nicely, so either (1) try to fit the whole anonymous function on one line or (2) break the whole thing out into a named function. Things tend to be clearer that way!" + ] + ) + + + +-- PATTERN + + +type PContext + = PCase + | PArg + | PLet + + +toPatternReport : SyntaxVersion -> Code.Source -> PContext -> Pattern -> Row -> Col -> Report.Report +toPatternReport syntaxVersion source context pattern startRow startCol = + case pattern of + PRecord record row col -> + toPRecordReport source record row col + + PTuple tuple row col -> + toPTupleReport syntaxVersion source context tuple row col + + PList list row col -> + toPListReport syntaxVersion source context list row col + + PStart row col -> + case Code.whatIsNext source row col of + Code.Keyword keyword -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toKeywordRegion row col keyword + + inThisThing : String + inThisThing = + case context of + PArg -> + "as an argument" + + PCase -> + "in this pattern" + + PLet -> + "in this pattern" + in + Report.Report "RESERVED WORD" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow <| + ("It looks like you are trying to use `" ++ keyword ++ "` " ++ inThisThing ++ ":") + , D.reflow <| + "This is a reserved word! Try using some other name?" + ) + + Code.Operator "-" -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + in + Report.Report "UNEXPECTED SYMBOL" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow <| + "I ran into a minus sign unexpectedly in this pattern:" + , D.reflow <| + "It is not possible to pattern match on negative numbers at this time. Try using an `if` expression for that sort of thing for now." + ) + + _ -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + in + Report.Report "PROBLEM IN PATTERN" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow <| + "I wanted to parse a pattern next, but I got stuck here:" + , D.fillSep + [ D.fromChars "I" + , D.fromChars "am" + , D.fromChars "not" + , D.fromChars "sure" + , D.fromChars "why" + , D.fromChars "I" + , D.fromChars "am" + , D.fromChars "getting" + , D.fromChars "stuck" + , D.fromChars "exactly." + , D.fromChars "I" + , D.fromChars "just" + , D.fromChars "know" + , D.fromChars "that" + , D.fromChars "I" + , D.fromChars "want" + , D.fromChars "a" + , D.fromChars "pattern" + , D.fromChars "next." + , D.fromChars "Something" + , D.fromChars "as" + , D.fromChars "simple" + , D.fromChars "as" + , D.dullyellow <| D.fromChars "maybeHeight" + , D.fromChars "or" + , D.dullyellow <| D.fromChars "result" + , D.fromChars "would" + , D.fromChars "work!" + ] + ) + + PChar char row col -> + toCharReport source char row col + + PString string row col -> + toStringReport source string row col + + PNumber number row col -> + toNumberReport syntaxVersion source number row col + + PFloat width row col -> + let + region : A.Region + region = + toWiderRegion row col width + in + Report.Report "UNEXPECTED PATTERN" region [] <| + Code.toSnippet source region Nothing <| + ( D.reflow <| + "I cannot pattern match with floating point numbers:" + , D.fillSep + [ D.fromChars "Equality" + , D.fromChars "on" + , D.fromChars "floats" + , D.fromChars "can" + , D.fromChars "be" + , D.fromChars "unreliable," + , D.fromChars "so" + , D.fromChars "you" + , D.fromChars "usually" + , D.fromChars "want" + , D.fromChars "to" + , D.fromChars "check" + , D.fromChars "that" + , D.fromChars "they" + , D.fromChars "are" + , D.fromChars "nearby" + , D.fromChars "with" + , D.fromChars "some" + , D.fromChars "sort" + , D.fromChars "of" + , D.dullyellow <| D.fromChars "(abs (actual - expected) < 0.001)" + , D.fromChars "check." + ] + ) + + PAlias row col -> + let + region : A.Region + region = + toRegion row col + in + Report.Report "UNFINISHED PATTERN" region [] <| + Code.toSnippet source region Nothing <| + ( D.reflow <| + "I was expecting to see a variable name after the `as` keyword:" + , D.stack + [ D.fillSep + [ D.fromChars "The" + , D.fromChars "`as`" + , D.fromChars "keyword" + , D.fromChars "lets" + , D.fromChars "you" + , D.fromChars "write" + , D.fromChars "patterns" + , D.fromChars "like" + , D.fromChars "((" + |> D.a (D.dullyellow (D.fromChars "x")) + |> D.a (D.fromChars ",") + |> D.a (D.dullyellow (D.fromChars "y")) + |> D.a (D.fromChars ") ") + |> D.a (D.cyan (D.fromChars "as")) + |> D.a (D.dullyellow (D.fromChars " point")) + |> D.a (D.fromChars ")") + , D.fromChars "so" + , D.fromChars "you" + , D.fromChars "can" + , D.fromChars "refer" + , D.fromChars "to" + , D.fromChars "individual" + , D.fromChars "parts" + , D.fromChars "of" + , D.fromChars "the" + , D.fromChars "tuple" + , D.fromChars "with" + , D.dullyellow <| D.fromChars "x" + , D.fromChars "and" + , D.dullyellow <| D.fromChars "y" + , D.fromChars "or" + , D.fromChars "you" + , D.fromChars "refer" + , D.fromChars "to" + , D.fromChars "the" + , D.fromChars "whole" + , D.fromChars "thing" + , D.fromChars "with" + , D.dullyellow (D.fromChars "point") + |> D.a (D.fromChars ".") + ] + , D.reflow <| + "So I was expecting to see a variable name after the `as` keyword here. Sometimes people just want to use `as` as a variable name though. Try using a different name in that case!" + ] + ) + + PWildcardNotVar name width row col -> + let + region : A.Region + region = + toWiderRegion row col width + + examples : List D.Doc + examples = + case String.uncons (String.filter ((/=) '_') name) of + Nothing -> + [ D.dullyellow (D.fromChars "x"), D.fromChars "or", D.dullyellow (D.fromChars "age") ] + + Just ( c, cs ) -> + [ D.dullyellow (D.fromChars (String.cons (Char.toLower c) cs)) ] + in + Report.Report "UNEXPECTED NAME" region [] <| + Code.toSnippet source region Nothing <| + ( D.reflow <| + "Variable names cannot start with underscores like this:" + , D.fillSep + ([ D.fromChars "You" + , D.fromChars "can" + , D.fromChars "either" + , D.fromChars "have" + , D.fromChars "an" + , D.fromChars "underscore" + , D.fromChars "like" + , D.dullyellow <| D.fromChars "_" + , D.fromChars "to" + , D.fromChars "ignore" + , D.fromChars "the" + , D.fromChars "value," + , D.fromChars "or" + , D.fromChars "you" + , D.fromChars "can" + , D.fromChars "have" + , D.fromChars "a" + , D.fromChars "name" + , D.fromChars "like" + ] + ++ examples + ++ [ D.fromChars "to" + , D.fromChars "use" + , D.fromChars "the" + , D.fromChars "matched" + , D.fromChars "value." + ] + ) + ) + + PWildcardReservedWord name width row col -> + let + region : A.Region + region = + toWiderRegion row col width + in + Report.Report "RESERVED WORD" region [] <| + Code.toSnippet source region Nothing <| + ( D.fillSep + [ D.fromChars "I" + , D.fromChars "ran" + , D.fromChars "into" + , D.fromChars "a" + , D.fromChars "reserved" + , D.fromChars "word" + , D.fromChars "in" + , D.fromChars "this" + , D.dullyellow <| D.fromChars "_" + , D.fromChars "variable:" + ] + , D.reflow <| + "The `" + ++ name + ++ "` keyword is reserved. Try using a different name instead!" + ) + + PSpace space row col -> + toSpaceReport source space row col + + PIndentStart row col -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + in + Report.Report "UNFINISHED PATTERN" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow <| + "I wanted to parse a pattern next, but I got stuck here:" + , D.stack + [ D.fillSep + [ D.fromChars "I" + , D.fromChars "am" + , D.fromChars "not" + , D.fromChars "sure" + , D.fromChars "why" + , D.fromChars "I" + , D.fromChars "am" + , D.fromChars "getting" + , D.fromChars "stuck" + , D.fromChars "exactly." + , D.fromChars "I" + , D.fromChars "just" + , D.fromChars "know" + , D.fromChars "that" + , D.fromChars "I" + , D.fromChars "want" + , D.fromChars "a" + , D.fromChars "pattern" + , D.fromChars "next." + , D.fromChars "Something" + , D.fromChars "as" + , D.fromChars "simple" + , D.fromChars "as" + , D.dullyellow <| D.fromChars "maybeHeight" + , D.fromChars "or" + , D.dullyellow <| D.fromChars "result" + , D.fromChars "would" + , D.fromChars "work!" + ] + , D.toSimpleNote <| + "I can get confused by indentation. If you think there is a pattern next, maybe it needs to be indented a bit more?" + ] + ) + + PIndentAlias row col -> + let + region : A.Region + region = + toRegion row col + in + Report.Report "UNFINISHED PATTERN" region [] <| + Code.toSnippet source region Nothing <| + ( D.reflow <| + "I was expecting to see a variable name after the `as` keyword:" + , D.stack + [ D.fillSep + [ D.fromChars "The" + , D.fromChars "`as`" + , D.fromChars "keyword" + , D.fromChars "lets" + , D.fromChars "you" + , D.fromChars "write" + , D.fromChars "patterns" + , D.fromChars "like" + , D.fromChars "((" + |> D.a (D.dullyellow (D.fromChars "x")) + |> D.a (D.fromChars ",") + |> D.a (D.dullyellow (D.fromChars "y")) + |> D.a (D.fromChars ") ") + |> D.a (D.cyan (D.fromChars "as")) + |> D.a (D.dullyellow (D.fromChars " point")) + |> D.a (D.fromChars ")") + , D.fromChars "so" + , D.fromChars "you" + , D.fromChars "can" + , D.fromChars "refer" + , D.fromChars "to" + , D.fromChars "individual" + , D.fromChars "parts" + , D.fromChars "of" + , D.fromChars "the" + , D.fromChars "tuple" + , D.fromChars "with" + , D.dullyellow <| D.fromChars "x" + , D.fromChars "and" + , D.dullyellow <| D.fromChars "y" + , D.fromChars "or" + , D.fromChars "you" + , D.fromChars "refer" + , D.fromChars "to" + , D.fromChars "the" + , D.fromChars "whole" + , D.fromChars "thing" + , D.fromChars "with" + , D.dullyellow <| D.fromChars "point." + ] + , D.reflow <| + "So I was expecting to see a variable name after the `as` keyword here. Sometimes people just want to use `as` as a variable name though. Try using a different name in that case!" + ] + ) + + +toPRecordReport : Code.Source -> PRecord -> Row -> Col -> Report.Report +toPRecordReport source record startRow startCol = + case record of + PRecordOpen row col -> + toUnfinishRecordPatternReport source row col startRow startCol <| + D.reflow "I was expecting to see a field name next." + + PRecordEnd row col -> + toUnfinishRecordPatternReport source row col startRow startCol <| + D.fillSep + [ D.fromChars "I" + , D.fromChars "was" + , D.fromChars "expecting" + , D.fromChars "to" + , D.fromChars "see" + , D.fromChars "a" + , D.fromChars "closing" + , D.fromChars "curly" + , D.fromChars "brace" + , D.fromChars "next." + , D.fromChars "Try" + , D.fromChars "adding" + , D.fromChars "a" + , D.dullyellow <| D.fromChars "}" + , D.fromChars "here?" + ] + + PRecordField row col -> + case Code.whatIsNext source row col of + Code.Keyword keyword -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toKeywordRegion row col keyword + in + Report.Report "RESERVED WORD" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow <| + "I was not expecting to see `" + ++ keyword + ++ "` as a record field name:" + , D.reflow <| + "This is a reserved word, not available for variable names. Try another name!" + ) + + _ -> + toUnfinishRecordPatternReport source row col startRow startCol <| + D.reflow "I was expecting to see a field name next." + + PRecordSpace space row col -> + toSpaceReport source space row col + + PRecordIndentOpen row col -> + toUnfinishRecordPatternReport source row col startRow startCol <| + D.reflow "I was expecting to see a field name next." + + PRecordIndentEnd row col -> + toUnfinishRecordPatternReport source row col startRow startCol <| + D.fillSep + [ D.fromChars "I" + , D.fromChars "was" + , D.fromChars "expecting" + , D.fromChars "to" + , D.fromChars "see" + , D.fromChars "a" + , D.fromChars "closing" + , D.fromChars "curly" + , D.fromChars "brace" + , D.fromChars "next." + , D.fromChars "Try" + , D.fromChars "adding" + , D.fromChars "a" + , D.dullyellow <| D.fromChars "}" + , D.fromChars "here?" + ] + + PRecordIndentField row col -> + toUnfinishRecordPatternReport source row col startRow startCol <| + D.reflow "I was expecting to see a field name next." + + +toUnfinishRecordPatternReport : Code.Source -> Row -> Col -> Row -> Col -> D.Doc -> Report.Report +toUnfinishRecordPatternReport source row col startRow startCol message = + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + in + Report.Report "UNFINISHED RECORD PATTERN" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow "I was partway through parsing a record pattern, but I got stuck here:" + , D.stack + [ message + , D.toFancyHint <| + [ D.fromChars "A" + , D.fromChars "record" + , D.fromChars "pattern" + , D.fromChars "looks" + , D.fromChars "like" + , D.dullyellow <| D.fromChars "{x,y}" + , D.fromChars "or" + , D.dullyellow <| D.fromChars "{name,age}" + , D.fromChars "where" + , D.fromChars "you" + , D.fromChars "list" + , D.fromChars "the" + , D.fromChars "field" + , D.fromChars "names" + , D.fromChars "you" + , D.fromChars "want" + , D.fromChars "to" + , D.fromChars "access." + ] + ] + ) + + +toPTupleReport : SyntaxVersion -> Code.Source -> PContext -> PTuple -> Row -> Col -> Report.Report +toPTupleReport syntaxVersion source context tuple startRow startCol = + case tuple of + PTupleOpen row col -> + case Code.whatIsNext source row col of + Code.Keyword keyword -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toKeywordRegion row col keyword + in + Report.Report "RESERVED WORD" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow <| + "It looks like you are trying to use `" + ++ keyword + ++ "` as a variable name:" + , D.reflow <| + "This is a reserved word! Try using some other name?" + ) + + _ -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + in + Report.Report "UNFINISHED PARENTHESES" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow <| + "I just saw an open parenthesis, but I got stuck here:" + , D.fillSep + [ D.fromChars "I" + , D.fromChars "was" + , D.fromChars "expecting" + , D.fromChars "to" + , D.fromChars "see" + , D.fromChars "a" + , D.fromChars "pattern" + , D.fromChars "next." + , D.fromChars "Maybe" + , D.fromChars "it" + , D.fromChars "will" + , D.fromChars "end" + , D.fromChars "up" + , D.fromChars "being" + , D.fromChars "something" + , D.fromChars "like" + , D.dullyellow <| D.fromChars "(x,y)" + , D.fromChars "or" + , D.dullyellow <| D.fromChars "(name, _)" + , D.fromChars "?" + ] + ) + + PTupleEnd row col -> + case Code.whatIsNext source row col of + Code.Keyword keyword -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toKeywordRegion row col keyword + in + Report.Report "RESERVED WORD" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow <| + "I ran into a reserved word in this pattern:" + , D.reflow <| + "The `" + ++ keyword + ++ "` keyword is reserved. Try using a different name instead!" + ) + + Code.Operator op -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toKeywordRegion row col op + in + Report.Report "UNEXPECTED SYMBOL" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow <| + "I ran into the " + ++ op + ++ " symbol unexpectedly in this pattern:" + , D.reflow <| + "Only the :: symbol that works in patterns. It is useful if you are pattern matching on lists, trying to get the first element off the front. Did you want that instead?" + ) + + Code.Close term bracket -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + in + Report.Report ("STRAY " ++ String.toUpper term) region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow <| + "I ran into a an unexpected " + ++ term + ++ " in this pattern:" + , D.reflow <| + "This " + ++ String.fromChar bracket + ++ " does not match up with an earlier open " + ++ term + ++ ". Try deleting it?" + ) + + _ -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + in + Report.Report "UNFINISHED PARENTHESES" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow <| + "I was partway through parsing a pattern, but I got stuck here:" + , D.fillSep + [ D.fromChars "I" + , D.fromChars "was" + , D.fromChars "expecting" + , D.fromChars "a" + , D.fromChars "closing" + , D.fromChars "parenthesis" + , D.fromChars "next," + , D.fromChars "so" + , D.fromChars "try" + , D.fromChars "adding" + , D.fromChars "a" + , D.dullyellow <| D.fromChars ")" + , D.fromChars "to" + , D.fromChars "see" + , D.fromChars "if" + , D.fromChars "that" + , D.fromChars "helps?" + ] + ) + + PTupleExpr pattern row col -> + toPatternReport syntaxVersion source context pattern row col + + PTupleSpace space row col -> + toSpaceReport source space row col + + PTupleIndentEnd row col -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + in + Report.Report "UNFINISHED PARENTHESES" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow <| + "I was expecting a closing parenthesis next:" + , D.stack + [ D.fillSep + [ D.fromChars "Try" + , D.fromChars "adding" + , D.fromChars "a" + , D.dullyellow <| D.fromChars ")" + , D.fromChars "to" + , D.fromChars "see" + , D.fromChars "if" + , D.fromChars "that" + , D.fromChars "helps?" + ] + , D.toSimpleNote <| + "I can get confused by indentation in cases like this, so maybe you have a closing parenthesis but it is not indented enough?" + ] + ) + + PTupleIndentExpr1 row col -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + in + Report.Report "UNFINISHED PARENTHESES" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow <| + "I just saw an open parenthesis, but then I got stuck here:" + , D.fillSep + [ D.fromChars "I" + , D.fromChars "was" + , D.fromChars "expecting" + , D.fromChars "to" + , D.fromChars "see" + , D.fromChars "a" + , D.fromChars "pattern" + , D.fromChars "next." + , D.fromChars "Maybe" + , D.fromChars "it" + , D.fromChars "will" + , D.fromChars "end" + , D.fromChars "up" + , D.fromChars "being" + , D.fromChars "something" + , D.fromChars "like" + , D.dullyellow <| D.fromChars "(x,y)" + , D.fromChars "or" + , D.dullyellow <| D.fromChars "(name, _)" + , D.fromChars "?" + ] + ) + + PTupleIndentExprN row col -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + in + Report.Report "UNFINISHED TUPLE PATTERN" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow <| + "I am partway through parsing a tuple pattern, but I got stuck here:" + , D.stack + [ D.fillSep + [ D.fromChars "I" + , D.fromChars "was" + , D.fromChars "expecting" + , D.fromChars "to" + , D.fromChars "see" + , D.fromChars "a" + , D.fromChars "pattern" + , D.fromChars "next." + , D.fromChars "I" + , D.fromChars "am" + , D.fromChars "expecting" + , D.fromChars "the" + , D.fromChars "final" + , D.fromChars "result" + , D.fromChars "to" + , D.fromChars "be" + , D.fromChars "something" + , D.fromChars "like" + , D.dullyellow <| D.fromChars "(x,y)" + , D.fromChars "or" + , D.dullyellow <| D.fromChars "(name, _)" + , D.fromChars "." + ] + , D.toSimpleNote <| + "I can get confused by indentation in cases like this, so the problem may be that the next part is not indented enough?" + ] + ) + + +toPListReport : SyntaxVersion -> Code.Source -> PContext -> PList -> Row -> Col -> Report.Report +toPListReport syntaxVersion source context list startRow startCol = + case list of + PListOpen row col -> + case Code.whatIsNext source row col of + Code.Keyword keyword -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toKeywordRegion row col keyword + in + Report.Report "RESERVED WORD" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow ("It looks like you are trying to use `" ++ keyword ++ "` to name an element of a list:") + , D.reflow "This is a reserved word though! Try using some other name?" + ) + + _ -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + in + Report.Report "UNFINISHED LIST PATTERN" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow "I just saw an open square bracket, but then I got stuck here:" + , D.fillSep + [ D.fromChars "Try" + , D.fromChars "adding" + , D.fromChars "a" + , D.dullyellow <| D.fromChars "]" + , D.fromChars "to" + , D.fromChars "see" + , D.fromChars "if" + , D.fromChars "that" + , D.fromChars "helps?" + ] + ) + + PListEnd row col -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + in + Report.Report "UNFINISHED LIST PATTERN" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow "I was expecting a closing square bracket to end this list pattern:" + , D.fillSep + [ D.fromChars "Try" + , D.fromChars "adding" + , D.fromChars "a" + , D.dullyellow <| D.fromChars "]" + , D.fromChars "to" + , D.fromChars "see" + , D.fromChars "if" + , D.fromChars "that" + , D.fromChars "helps?" + ] + ) + + PListExpr pattern row col -> + toPatternReport syntaxVersion source context pattern row col + + PListSpace space row col -> + toSpaceReport source space row col + + PListIndentOpen row col -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + in + Report.Report "UNFINISHED LIST PATTERN" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow "I just saw an open square bracket, but then I got stuck here:" + , D.stack + [ D.fillSep + [ D.fromChars "Try" + , D.fromChars "adding" + , D.fromChars "a" + , D.dullyellow <| D.fromChars "]" + , D.fromChars "to" + , D.fromChars "see" + , D.fromChars "if" + , D.fromChars "that" + , D.fromChars "helps?" + ] + , D.toSimpleNote "I can get confused by indentation in cases like this, so maybe there is something next, but it is not indented enough?" + ] + ) + + PListIndentEnd row col -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + in + Report.Report "UNFINISHED LIST PATTERN" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow "I was expecting a closing square bracket to end this list pattern:" + , D.stack + [ D.fillSep + [ D.fromChars "Try" + , D.fromChars "adding" + , D.fromChars "a" + , D.dullyellow <| D.fromChars "]" + , D.fromChars "to" + , D.fromChars "see" + , D.fromChars "if" + , D.fromChars "that" + , D.fromChars "helps?" + ] + , D.toSimpleNote "I can get confused by indentation in cases like this, so maybe you have a closing square bracket but it is not indented enough?" + ] + ) + + PListIndentExpr row col -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + in + Report.Report "UNFINISHED LIST PATTERN" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow "I am partway through parsing a list pattern, but I got stuck here:" + , D.stack + [ D.reflow "I was expecting to see another pattern next. Maybe a variable name." + , D.toSimpleNote "I can get confused by indentation in cases like this, so maybe there is more to this pattern but it is not indented enough?" + ] + ) + + + +-- TYPES + + +type TContext + = TC_Annotation Name + | TC_CustomType + | TC_TypeAlias + | TC_Port + + +toTypeReport : Code.Source -> TContext -> Type -> Row -> Col -> Report.Report +toTypeReport source context tipe startRow startCol = + case tipe of + TRecord record row col -> + toTRecordReport source context record row col + + TTuple tuple row col -> + toTTupleReport source context tuple row col + + TStart row col -> + case Code.whatIsNext source row col of + Code.Keyword keyword -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toKeywordRegion row col keyword + in + Report.Report "RESERVED WORD" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow "I was expecting to see a type next, but I got stuck on this reserved word:" + , D.reflow ("It looks like you are trying to use `" ++ keyword ++ "` as a type variable, but it is a reserved word. Try using a different name!") + ) + + _ -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + + thing : String + thing = + case context of + TC_Annotation _ -> + "type annotation" + + TC_CustomType -> + "custom type" + + TC_TypeAlias -> + "type alias" + + TC_Port -> + "port" + + something : String + something = + case context of + TC_Annotation name -> + "the `" ++ name ++ "` type annotation" + + TC_CustomType -> + "a custom type" + + TC_TypeAlias -> + "a type alias" + + TC_Port -> + "a port" + in + Report.Report ("PROBLEM IN " ++ String.toUpper thing) region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow ("I was partway through parsing " ++ something ++ ", but I got stuck here:") + , D.fillSep + [ D.fromChars "I" + , D.fromChars "was" + , D.fromChars "expecting" + , D.fromChars "to" + , D.fromChars "see" + , D.fromChars "a" + , D.fromChars "type" + , D.fromChars "next." + , D.fromChars "Try" + , D.fromChars "putting" + , D.dullyellow <| D.fromChars "Int" + , D.fromChars "or" + , D.dullyellow <| D.fromChars "String" + , D.fromChars "for" + , D.fromChars "now?" + ] + ) + + TSpace space row col -> + toSpaceReport source space row col + + TIndentStart row col -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + + thing : String + thing = + case context of + TC_Annotation _ -> + "type annotation" + + TC_CustomType -> + "custom type" + + TC_TypeAlias -> + "type alias" + + TC_Port -> + "port" + in + Report.Report ("UNFINISHED " ++ String.toUpper thing) region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow ("I was partway through parsing a " ++ thing ++ ", but I got stuck here:") + , D.stack + [ D.fillSep + [ D.fromChars "I" + , D.fromChars "was" + , D.fromChars "expecting" + , D.fromChars "to" + , D.fromChars "see" + , D.fromChars "a" + , D.fromChars "type" + , D.fromChars "next." + , D.fromChars "Try" + , D.fromChars "putting" + , D.dullyellow <| D.fromChars "Int" + , D.fromChars "or" + , D.dullyellow <| D.fromChars "String" + , D.fromChars "for" + , D.fromChars "now?" + ] + , D.toSimpleNote "I can get confused by indentation. If you think there is already a type next, maybe it is not indented enough?" + ] + ) + + +toTRecordReport : Code.Source -> TContext -> TRecord -> Row -> Col -> Report.Report +toTRecordReport source context record startRow startCol = + case record of + TRecordOpen row col -> + case Code.whatIsNext source row col of + Code.Keyword keyword -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toKeywordRegion row col keyword + in + Report.Report "RESERVED WORD" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow "I just started parsing a record type, but I got stuck on this field name:" + , D.reflow ("It looks like you are trying to use `" ++ keyword ++ "` as a field name, but that is a reserved word. Try using a different name!") + ) + + _ -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + in + Report.Report "UNFINISHED RECORD TYPE" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow "I just started parsing a record type, but I got stuck here:" + , D.fillSep + [ D.fromChars "Record" + , D.fromChars "types" + , D.fromChars "look" + , D.fromChars "like" + , D.dullyellow <| D.fromChars "{ name : String, age : Int }," + , D.fromChars "so" + , D.fromChars "I" + , D.fromChars "was" + , D.fromChars "expecting" + , D.fromChars "to" + , D.fromChars "see" + , D.fromChars "a" + , D.fromChars "field" + , D.fromChars "name" + , D.fromChars "next." + ] + ) + + TRecordEnd row col -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + in + Report.Report "UNFINISHED RECORD TYPE" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow "I am partway through parsing a record type, but I got stuck here:" + , D.stack + [ D.fillSep + [ D.fromChars "I" + , D.fromChars "was" + , D.fromChars "expecting" + , D.fromChars "to" + , D.fromChars "see" + , D.fromChars "a" + , D.fromChars "closing" + , D.fromChars "curly" + , D.fromChars "brace" + , D.fromChars "before" + , D.fromChars "this," + , D.fromChars "so" + , D.fromChars "try" + , D.fromChars "adding" + , D.fromChars "a" + , D.dullyellow <| D.fromChars "}" + , D.fromChars "and" + , D.fromChars "see" + , D.fromChars "if" + , D.fromChars "that" + , D.fromChars "helps?" + ] + , D.toSimpleNote "When I get stuck like this, it usually means that there is a missing parenthesis or bracket somewhere earlier. It could also be a stray keyword or operator." + ] + ) + + TRecordField row col -> + case Code.whatIsNext source row col of + Code.Keyword keyword -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toKeywordRegion row col keyword + in + Report.Report "RESERVED WORD" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow "I am partway through parsing a record type, but I got stuck on this field name:" + , D.reflow ("It looks like you are trying to use `" ++ keyword ++ "` as a field name, but that is a reserved word. Try using a different name!") + ) + + Code.Other (Just ',') -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + in + Report.Report "EXTRA COMMA" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow "I am partway through parsing a record type, but I got stuck here:" + , D.stack + [ D.reflow "I am seeing two commas in a row. This is the second one!" + , D.reflow "Just delete one of the commas and you should be all set!" + , noteForRecordTypeError + ] + ) + + Code.Close _ '}' -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + in + Report.Report "EXTRA COMMA" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow "I am partway through parsing a record type, but I got stuck here:" + , D.stack + [ D.reflow "Trailing commas are not allowed in record types. Try deleting the comma that appears before this closing curly brace." + , noteForRecordTypeError + ] + ) + + _ -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + in + Report.Report "PROBLEM IN RECORD TYPE" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow "I am partway through parsing a record type, but I got stuck here:" + , D.stack + [ D.fillSep + [ D.fromChars "I" + , D.fromChars "was" + , D.fromChars "expecting" + , D.fromChars "to" + , D.fromChars "see" + , D.fromChars "another" + , D.fromChars "record" + , D.fromChars "field" + , D.fromChars "defined" + , D.fromChars "next," + , D.fromChars "so" + , D.fromChars "I" + , D.fromChars "am" + , D.fromChars "looking" + , D.fromChars "for" + , D.fromChars "a" + , D.fromChars "name" + , D.fromChars "like" + , D.dullyellow (D.fromChars "userName") + , D.fromChars "or" + , D.dullyellow (D.fromChars "plantHeight") + |> D.a (D.fromChars ".") + ] + , noteForRecordTypeError + ] + ) + + TRecordColon row col -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + in + Report.Report "UNFINISHED RECORD TYPE" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow "I am partway through parsing a record type, but I got stuck here:" + , D.stack + [ D.fillSep + [ D.fromChars "I" + , D.fromChars "just" + , D.fromChars "saw" + , D.fromChars "a" + , D.fromChars "field" + , D.fromChars "name," + , D.fromChars "so" + , D.fromChars "I" + , D.fromChars "was" + , D.fromChars "expecting" + , D.fromChars "to" + , D.fromChars "see" + , D.fromChars "a" + , D.fromChars "colon" + , D.fromChars "next." + , D.fromChars "So" + , D.fromChars "try" + , D.fromChars "putting" + , D.fromChars "an" + , D.green <| D.fromChars ":" + , D.fromChars "sign" + , D.fromChars "here?" + ] + , noteForRecordTypeError + ] + ) + + TRecordType tipe row col -> + toTypeReport source context tipe row col + + TRecordSpace space row col -> + toSpaceReport source space row col + + TRecordIndentOpen row col -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + in + Report.Report "UNFINISHED RECORD TYPE" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow "I just saw the opening curly brace of a record type, but then I got stuck here:" + , D.stack + [ D.fillSep + [ D.fromChars "I" + , D.fromChars "am" + , D.fromChars "expecting" + , D.fromChars "a" + , D.fromChars "record" + , D.fromChars "like" + , D.dullyellow <| D.fromChars "{ name : String, age : Int }" + , D.fromChars "here." + , D.fromChars "Try" + , D.fromChars "defining" + , D.fromChars "some" + , D.fromChars "fields" + , D.fromChars "of" + , D.fromChars "your" + , D.fromChars "own?" + ] + , noteForRecordTypeIndentError + ] + ) + + TRecordIndentEnd row col -> + case Code.nextLineStartsWithCloseCurly source row of + Just ( curlyRow, curlyCol ) -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position curlyRow curlyCol) + + region : A.Region + region = + toRegion curlyRow curlyCol + in + Report.Report "NEED MORE INDENTATION" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow "I was partway through parsing a record type, but I got stuck here:" + , D.stack + [ D.reflow "I need this curly brace to be indented more. Try adding some spaces before it!" + , noteForRecordTypeError + ] + ) + + Nothing -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + in + Report.Report "UNFINISHED RECORD TYPE" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow "I was partway through parsing a record type, but I got stuck here:" + , D.stack + [ D.fillSep + [ D.fromChars "I" + , D.fromChars "was" + , D.fromChars "expecting" + , D.fromChars "to" + , D.fromChars "see" + , D.fromChars "a" + , D.fromChars "closing" + , D.fromChars "curly" + , D.fromChars "brace" + , D.fromChars "next." + , D.fromChars "Try" + , D.fromChars "putting" + , D.fromChars "a" + , D.green <| D.fromChars "}" + , D.fromChars "next" + , D.fromChars "and" + , D.fromChars "see" + , D.fromChars "if" + , D.fromChars "that" + , D.fromChars "helps?" + ] + , noteForRecordTypeIndentError + ] + ) + + TRecordIndentField row col -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + in + Report.Report "UNFINISHED RECORD TYPE" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow "I am partway through parsing a record type, but I got stuck after that last comma:" + , D.stack + [ D.reflow "Trailing commas are not allowed in record types, so the fix may be to delete that last comma? Or maybe you were in the middle of defining an additional field?" + , noteForRecordTypeIndentError + ] + ) + + TRecordIndentColon row col -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + in + Report.Report "UNFINISHED RECORD TYPE" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow "I am partway through parsing a record type. I just saw a record field, so I was expecting to see a colon next:" + , D.stack + [ D.fillSep + [ D.fromChars "Try" + , D.fromChars "putting" + , D.fromChars "an" + , D.green <| D.fromChars ":" + , D.fromChars "followed" + , D.fromChars "by" + , D.fromChars "a" + , D.fromChars "type?" + ] + , noteForRecordTypeIndentError + ] + ) + + TRecordIndentType row col -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + in + Report.Report "UNFINISHED RECORD TYPE" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow "I am partway through parsing a record type, and I was expecting to run into a type next:" + , D.stack + [ D.fillSep + [ D.fromChars "Try" + , D.fromChars "putting" + , D.fromChars "something" + , D.fromChars "like" + , D.dullyellow <| D.fromChars "Int" + , D.fromChars "or" + , D.dullyellow <| D.fromChars "String" + , D.fromChars "for" + , D.fromChars "now?" + ] + , noteForRecordTypeIndentError + ] + ) + + +noteForRecordTypeError : D.Doc +noteForRecordTypeError = + D.stack + [ D.toSimpleNote + "If you are trying to define a record type across multiple lines, I recommend using this format:" + , D.indent 4 <| + D.vcat + [ D.fromChars "{ name : String" + , D.fromChars ", age : Int" + , D.fromChars ", height : Float" + , D.fromChars "}" + ] + , D.reflow + "Notice that each line starts with some indentation. Usually two or four spaces. This is the stylistic convention in the Elm ecosystem." + ] + + +noteForRecordTypeIndentError : D.Doc +noteForRecordTypeIndentError = + D.stack + [ D.toSimpleNote + "I may be confused by indentation. For example, if you are trying to define a record type across multiple lines, I recommend using this format:" + , D.indent 4 <| + D.vcat + [ D.fromChars "{ name : String" + , D.fromChars ", age : Int" + , D.fromChars ", height : Float" + , D.fromChars "}" + ] + , D.reflow + "Notice that each line starts with some indentation. Usually two or four spaces. This is the stylistic convention in the Elm ecosystem." + ] + + +toTTupleReport : Code.Source -> TContext -> TTuple -> Row -> Col -> Report.Report +toTTupleReport source context tuple startRow startCol = + case tuple of + TTupleOpen row col -> + case Code.whatIsNext source row col of + Code.Keyword keyword -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toKeywordRegion row col keyword + in + Report.Report "RESERVED WORD" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow + "I ran into a reserved word unexpectedly:" + , D.reflow + ("It looks like you are trying to use `" ++ keyword ++ "` as a variable name, but it is a reserved word. Try using a different name!") + ) + + _ -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + in + Report.Report "UNFINISHED PARENTHESES" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow + "I just saw an open parenthesis, so I was expecting to see a type next." + , D.fillSep + [ D.fromChars "Something" + , D.fromChars "like" + , D.dullyellow <| D.fromChars "(Maybe Int)" + , D.fromChars "or" + , D.dullyellow (D.fromChars "(List Person)") |> D.a (D.fromChars ".") + , D.fromChars "Anything" + , D.fromChars "where" + , D.fromChars "you" + , D.fromChars "are" + , D.fromChars "putting" + , D.fromChars "parentheses" + , D.fromChars "around" + , D.fromChars "normal" + , D.fromChars "types." + ] + ) + + TTupleEnd row col -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + in + Report.Report "UNFINISHED PARENTHESES" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow + "I was expecting to see a closing parenthesis next, but I got stuck here:" + , D.stack + [ D.fillSep + [ D.fromChars "Try" + , D.fromChars "adding" + , D.fromChars "a" + , D.dullyellow <| D.fromChars ")" + , D.fromChars "to" + , D.fromChars "see" + , D.fromChars "if" + , D.fromChars "that" + , D.fromChars "helps?" + ] + , D.toSimpleNote + "I can get stuck when I run into keywords, operators, parentheses, or brackets unexpectedly. So there may be some earlier syntax trouble (like extra parenthesis or missing brackets) that is confusing me." + ] + ) + + TTupleType tipe row col -> + toTypeReport source context tipe row col + + TTupleSpace space row col -> + toSpaceReport source space row col + + TTupleIndentType1 row col -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + in + Report.Report "UNFINISHED PARENTHESES" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow + "I just saw an open parenthesis, so I was expecting to see a type next." + , D.stack + [ D.fillSep + [ D.fromChars "Something" + , D.fromChars "like" + , D.dullyellow <| D.fromChars "(Maybe Int)" + , D.fromChars "or" + , D.dullyellow (D.fromChars "(List Person)") |> D.a (D.fromChars ".") + , D.fromChars "Anything" + , D.fromChars "where" + , D.fromChars "you" + , D.fromChars "are" + , D.fromChars "putting" + , D.fromChars "parentheses" + , D.fromChars "around" + , D.fromChars "normal" + , D.fromChars "types." + ] + , D.toSimpleNote + "I can get confused by indentation in cases like this, so maybe you have a type but it is not indented enough?" + ] + ) + + TTupleIndentTypeN row col -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + in + Report.Report "UNFINISHED TUPLE TYPE" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow + "I think I am in the middle of parsing a tuple type. I just saw a comma, so I was expecting to see a type next." + , D.stack + [ D.fillSep + [ D.fromChars "A" + , D.fromChars "tuple" + , D.fromChars "type" + , D.fromChars "looks" + , D.fromChars "like" + , D.dullyellow <| D.fromChars "(Float,Float)" + , D.fromChars "or" + , D.dullyellow (D.fromChars "(String,Int)") |> D.a (D.fromChars ",") + , D.fromChars "so" + , D.fromChars "I" + , D.fromChars "think" + , D.fromChars "there" + , D.fromChars "is" + , D.fromChars "a" + , D.fromChars "type" + , D.fromChars "missing" + , D.fromChars "here?" + ] + , D.toSimpleNote + "I can get confused by indentation in cases like this, so maybe you have an expression but it is not indented enough?" + ] + ) + + TTupleIndentEnd row col -> + let + surroundings : A.Region + surroundings = + A.Region (A.Position startRow startCol) (A.Position row col) + + region : A.Region + region = + toRegion row col + in + Report.Report "UNFINISHED PARENTHESES" region [] <| + Code.toSnippet source surroundings (Just region) <| + ( D.reflow + "I was expecting to see a closing parenthesis next:" + , D.stack + [ D.fillSep + [ D.fromChars "Try" + , D.fromChars "adding" + , D.fromChars "a" + , D.dullyellow <| D.fromChars ")" + , D.fromChars "to" + , D.fromChars "see" + , D.fromChars "if" + , D.fromChars "that" + , D.fromChars "helps!" + ] + , D.toSimpleNote + "I can get confused by indentation in cases like this, so maybe you have a closing parenthesis but it is not indented enough?" + ] + ) + + + +-- ENCODERS and DECODERS + + +errorEncoder : Error -> BE.Encoder +errorEncoder error = + case error of + ModuleNameUnspecified name -> + BE.sequence + [ BE.unsignedInt8 0 + , ModuleName.rawEncoder name + ] + + ModuleNameMismatch expectedName actualName -> + BE.sequence + [ BE.unsignedInt8 1 + , ModuleName.rawEncoder expectedName + , A.locatedEncoder ModuleName.rawEncoder actualName + ] + + UnexpectedPort region -> + BE.sequence + [ BE.unsignedInt8 2 + , A.regionEncoder region + ] + + NoPorts region -> + BE.sequence + [ BE.unsignedInt8 3 + , A.regionEncoder region + ] + + NoPortsInPackage name -> + BE.sequence + [ BE.unsignedInt8 4 + , A.locatedEncoder BE.string name + ] + + NoPortModulesInPackage region -> + BE.sequence + [ BE.unsignedInt8 5 + , A.regionEncoder region + ] + + NoEffectsOutsideKernel region -> + BE.sequence + [ BE.unsignedInt8 6 + , A.regionEncoder region + ] + + ParseError modul -> + BE.sequence + [ BE.unsignedInt8 7 + , moduleEncoder modul + ] + + +errorDecoder : BD.Decoder Error +errorDecoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.map ModuleNameUnspecified ModuleName.rawDecoder + + 1 -> + BD.map2 ModuleNameMismatch + ModuleName.rawDecoder + (A.locatedDecoder ModuleName.rawDecoder) + + 2 -> + BD.map UnexpectedPort A.regionDecoder + + 3 -> + BD.map NoPorts A.regionDecoder + + 4 -> + BD.map NoPortsInPackage (A.locatedDecoder BD.string) + + 5 -> + BD.map NoPortModulesInPackage A.regionDecoder + + 6 -> + BD.map NoEffectsOutsideKernel A.regionDecoder + + 7 -> + BD.map ParseError moduleDecoder + + _ -> + BD.fail + ) + + +spaceEncoder : Space -> BE.Encoder +spaceEncoder space = + BE.unsignedInt8 + (case space of + HasTab -> + 0 + + EndlessMultiComment -> + 1 + ) + + +spaceDecoder : BD.Decoder Space +spaceDecoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.succeed HasTab + + 1 -> + BD.succeed EndlessMultiComment + + _ -> + BD.fail + ) + + +moduleEncoder : Module -> BE.Encoder +moduleEncoder modul = + case modul of + ModuleSpace space row col -> + BE.sequence + [ BE.unsignedInt8 0 + , spaceEncoder space + , BE.int row + , BE.int col + ] + + ModuleBadEnd row col -> + BE.sequence + [ BE.unsignedInt8 1 + , BE.int row + , BE.int col + ] + + ModuleProblem row col -> + BE.sequence + [ BE.unsignedInt8 2 + , BE.int row + , BE.int col + ] + + ModuleName row col -> + BE.sequence + [ BE.unsignedInt8 3 + , BE.int row + , BE.int col + ] + + ModuleExposing exposing_ row col -> + BE.sequence + [ BE.unsignedInt8 4 + , exposingEncoder exposing_ + , BE.int row + , BE.int col + ] + + PortModuleProblem row col -> + BE.sequence + [ BE.unsignedInt8 5 + , BE.int row + , BE.int col + ] + + PortModuleName row col -> + BE.sequence + [ BE.unsignedInt8 6 + , BE.int row + , BE.int col + ] + + PortModuleExposing exposing_ row col -> + BE.sequence + [ BE.unsignedInt8 7 + , exposingEncoder exposing_ + , BE.int row + , BE.int col + ] + + Effect row col -> + BE.sequence + [ BE.unsignedInt8 8 + , BE.int row + , BE.int col + ] + + FreshLine row col -> + BE.sequence + [ BE.unsignedInt8 9 + , BE.int row + , BE.int col + ] + + ImportStart row col -> + BE.sequence + [ BE.unsignedInt8 10 + , BE.int row + , BE.int col + ] + + ImportName row col -> + BE.sequence + [ BE.unsignedInt8 11 + , BE.int row + , BE.int col + ] + + ImportAs row col -> + BE.sequence + [ BE.unsignedInt8 12 + , BE.int row + , BE.int col + ] + + ImportAlias row col -> + BE.sequence + [ BE.unsignedInt8 13 + , BE.int row + , BE.int col + ] + + ImportExposing row col -> + BE.sequence + [ BE.unsignedInt8 14 + , BE.int row + , BE.int col + ] + + ImportExposingList exposing_ row col -> + BE.sequence + [ BE.unsignedInt8 15 + , exposingEncoder exposing_ + , BE.int row + , BE.int col + ] + + ImportEnd row col -> + BE.sequence + [ BE.unsignedInt8 16 + , BE.int row + , BE.int col + ] + + ImportIndentName row col -> + BE.sequence + [ BE.unsignedInt8 17 + , BE.int row + , BE.int col + ] + + ImportIndentAlias row col -> + BE.sequence + [ BE.unsignedInt8 18 + , BE.int row + , BE.int col + ] + + ImportIndentExposingList row col -> + BE.sequence + [ BE.unsignedInt8 19 + , BE.int row + , BE.int col + ] + + Infix row col -> + BE.sequence + [ BE.unsignedInt8 20 + , BE.int row + , BE.int col + ] + + Declarations decl row col -> + BE.sequence + [ BE.unsignedInt8 21 + , declEncoder decl + , BE.int row + , BE.int col + ] + + +moduleDecoder : BD.Decoder Module +moduleDecoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.map3 ModuleSpace + spaceDecoder + BD.int + BD.int + + 1 -> + BD.map2 ModuleBadEnd + BD.int + BD.int + + 2 -> + BD.map2 ModuleProblem + BD.int + BD.int + + 3 -> + BD.map2 ModuleName + BD.int + BD.int + + 4 -> + BD.map3 ModuleExposing + exposingDecoder + BD.int + BD.int + + 5 -> + BD.map2 PortModuleProblem + BD.int + BD.int + + 6 -> + BD.map2 PortModuleName + BD.int + BD.int + + 7 -> + BD.map3 PortModuleExposing + exposingDecoder + BD.int + BD.int + + 8 -> + BD.map2 Effect + BD.int + BD.int + + 9 -> + BD.map2 FreshLine + BD.int + BD.int + + 10 -> + BD.map2 ImportStart + BD.int + BD.int + + 11 -> + BD.map2 ImportName + BD.int + BD.int + + 12 -> + BD.map2 ImportAs + BD.int + BD.int + + 13 -> + BD.map2 ImportAlias + BD.int + BD.int + + 14 -> + BD.map2 ImportExposing + BD.int + BD.int + + 15 -> + BD.map3 ImportExposingList + exposingDecoder + BD.int + BD.int + + 16 -> + BD.map2 ImportEnd + BD.int + BD.int + + 17 -> + BD.map2 ImportIndentName + BD.int + BD.int + + 18 -> + BD.map2 ImportIndentAlias + BD.int + BD.int + + 19 -> + BD.map2 ImportIndentExposingList + BD.int + BD.int + + 20 -> + BD.map2 Infix + BD.int + BD.int + + 21 -> + BD.map3 Declarations + declDecoder + BD.int + BD.int + + _ -> + BD.fail + ) + + +exposingEncoder : Exposing -> BE.Encoder +exposingEncoder exposing_ = + case exposing_ of + ExposingSpace space row col -> + BE.sequence + [ BE.unsignedInt8 0 + , spaceEncoder space + , BE.int row + , BE.int col + ] + + ExposingStart row col -> + BE.sequence + [ BE.unsignedInt8 1 + , BE.int row + , BE.int col + ] + + ExposingValue row col -> + BE.sequence + [ BE.unsignedInt8 2 + , BE.int row + , BE.int col + ] + + ExposingOperator row col -> + BE.sequence + [ BE.unsignedInt8 3 + , BE.int row + , BE.int col + ] + + ExposingOperatorReserved op row col -> + BE.sequence + [ BE.unsignedInt8 4 + , Symbol.badOperatorEncoder op + , BE.int row + , BE.int col + ] + + ExposingOperatorRightParen row col -> + BE.sequence + [ BE.unsignedInt8 5 + , BE.int row + , BE.int col + ] + + ExposingTypePrivacy row col -> + BE.sequence + [ BE.unsignedInt8 6 + , BE.int row + , BE.int col + ] + + ExposingEnd row col -> + BE.sequence + [ BE.unsignedInt8 7 + , BE.int row + , BE.int col + ] + + ExposingIndentEnd row col -> + BE.sequence + [ BE.unsignedInt8 8 + , BE.int row + , BE.int col + ] + + ExposingIndentValue row col -> + BE.sequence + [ BE.unsignedInt8 9 + , BE.int row + , BE.int col + ] + + +exposingDecoder : BD.Decoder Exposing +exposingDecoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.map3 ExposingSpace + spaceDecoder + BD.int + BD.int + + 1 -> + BD.map2 ExposingStart + BD.int + BD.int + + 2 -> + BD.map2 ExposingValue + BD.int + BD.int + + 3 -> + BD.map2 ExposingOperator + BD.int + BD.int + + 4 -> + BD.map3 ExposingOperatorReserved + Symbol.badOperatorDecoder + BD.int + BD.int + + 5 -> + BD.map2 ExposingOperatorRightParen + BD.int + BD.int + + 6 -> + BD.map2 ExposingTypePrivacy + BD.int + BD.int + + 7 -> + BD.map2 ExposingEnd + BD.int + BD.int + + 8 -> + BD.map2 ExposingIndentEnd + BD.int + BD.int + + 9 -> + BD.map2 ExposingIndentValue + BD.int + BD.int + + _ -> + BD.fail + ) + + +declEncoder : Decl -> BE.Encoder +declEncoder decl = + case decl of + DeclStart row col -> + BE.sequence + [ BE.unsignedInt8 0 + , BE.int row + , BE.int col + ] + + DeclSpace space row col -> + BE.sequence + [ BE.unsignedInt8 1 + , spaceEncoder space + , BE.int row + , BE.int col + ] + + Port port_ row col -> + BE.sequence + [ BE.unsignedInt8 2 + , portEncoder port_ + , BE.int row + , BE.int col + ] + + DeclType declType row col -> + BE.sequence + [ BE.unsignedInt8 3 + , declTypeEncoder declType + , BE.int row + , BE.int col + ] + + DeclDef name declDef row col -> + BE.sequence + [ BE.unsignedInt8 4 + , BE.string name + , declDefEncoder declDef + , BE.int row + , BE.int col + ] + + DeclFreshLineAfterDocComment row col -> + BE.sequence + [ BE.unsignedInt8 5 + , BE.int row + , BE.int col + ] + + +declDecoder : BD.Decoder Decl +declDecoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.map2 DeclStart + BD.int + BD.int + + 1 -> + BD.map3 DeclSpace + spaceDecoder + BD.int + BD.int + + 2 -> + BD.map3 Port + portDecoder + BD.int + BD.int + + 3 -> + BD.map3 DeclType + declTypeDecoder + BD.int + BD.int + + 4 -> + BD.map4 DeclDef + BD.string + declDefDecoder + BD.int + BD.int + + 5 -> + BD.map2 DeclFreshLineAfterDocComment + BD.int + BD.int + + _ -> + BD.fail + ) + + +portEncoder : Port -> BE.Encoder +portEncoder port_ = + case port_ of + PortSpace space row col -> + BE.sequence + [ BE.unsignedInt8 0 + , spaceEncoder space + , BE.int row + , BE.int col + ] + + PortName row col -> + BE.sequence + [ BE.unsignedInt8 1 + , BE.int row + , BE.int col + ] + + PortColon row col -> + BE.sequence + [ BE.unsignedInt8 2 + , BE.int row + , BE.int col + ] + + PortType tipe row col -> + BE.sequence + [ BE.unsignedInt8 3 + , typeEncoder tipe + , BE.int row + , BE.int col + ] + + PortIndentName row col -> + BE.sequence + [ BE.unsignedInt8 4 + , BE.int row + , BE.int col + ] + + PortIndentColon row col -> + BE.sequence + [ BE.unsignedInt8 5 + , BE.int row + , BE.int col + ] + + PortIndentType row col -> + BE.sequence + [ BE.unsignedInt8 6 + , BE.int row + , BE.int col + ] + + +portDecoder : BD.Decoder Port +portDecoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.map3 PortSpace + spaceDecoder + BD.int + BD.int + + 1 -> + BD.map2 PortName + BD.int + BD.int + + 2 -> + BD.map2 PortColon + BD.int + BD.int + + 3 -> + BD.map3 PortType + typeDecoder + BD.int + BD.int + + 4 -> + BD.map2 PortIndentName + BD.int + BD.int + + 5 -> + BD.map2 PortIndentColon + BD.int + BD.int + + 6 -> + BD.map2 PortIndentType + BD.int + BD.int + + _ -> + BD.fail + ) + + +declTypeEncoder : DeclType -> BE.Encoder +declTypeEncoder declType = + case declType of + DT_Space space row col -> + BE.sequence + [ BE.unsignedInt8 0 + , spaceEncoder space + , BE.int row + , BE.int col + ] + + DT_Name row col -> + BE.sequence + [ BE.unsignedInt8 1 + , BE.int row + , BE.int col + ] + + DT_Alias typeAlias row col -> + BE.sequence + [ BE.unsignedInt8 2 + , typeAliasEncoder typeAlias + , BE.int row + , BE.int col + ] + + DT_Union customType row col -> + BE.sequence + [ BE.unsignedInt8 3 + , customTypeEncoder customType + , BE.int row + , BE.int col + ] + + DT_IndentName row col -> + BE.sequence + [ BE.unsignedInt8 4 + , BE.int row + , BE.int col + ] + + +declTypeDecoder : BD.Decoder DeclType +declTypeDecoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.map3 DT_Space + spaceDecoder + BD.int + BD.int + + 1 -> + BD.map2 DT_Name + BD.int + BD.int + + 2 -> + BD.map3 DT_Alias + typeAliasDecoder + BD.int + BD.int + + 3 -> + BD.map3 DT_Union + customTypeDecoder + BD.int + BD.int + + 4 -> + BD.map2 DT_IndentName + BD.int + BD.int + + _ -> + BD.fail + ) + + +declDefEncoder : DeclDef -> BE.Encoder +declDefEncoder declDef = + case declDef of + DeclDefSpace space row col -> + BE.sequence + [ BE.unsignedInt8 0 + , spaceEncoder space + , BE.int row + , BE.int col + ] + + DeclDefEquals row col -> + BE.sequence + [ BE.unsignedInt8 1 + , BE.int row + , BE.int col + ] + + DeclDefType tipe row col -> + BE.sequence + [ BE.unsignedInt8 2 + , typeEncoder tipe + , BE.int row + , BE.int col + ] + + DeclDefArg pattern row col -> + BE.sequence + [ BE.unsignedInt8 3 + , patternEncoder pattern + , BE.int row + , BE.int col + ] + + DeclDefBody expr row col -> + BE.sequence + [ BE.unsignedInt8 4 + , exprEncoder expr + , BE.int row + , BE.int col + ] + + DeclDefNameRepeat row col -> + BE.sequence + [ BE.unsignedInt8 5 + , BE.int row + , BE.int col + ] + + DeclDefNameMatch name row col -> + BE.sequence + [ BE.unsignedInt8 6 + , BE.string name + , BE.int row + , BE.int col + ] + + DeclDefIndentType row col -> + BE.sequence + [ BE.unsignedInt8 7 + , BE.int row + , BE.int col + ] + + DeclDefIndentEquals row col -> + BE.sequence + [ BE.unsignedInt8 8 + , BE.int row + , BE.int col + ] + + DeclDefIndentBody row col -> + BE.sequence + [ BE.unsignedInt8 9 + , BE.int row + , BE.int col + ] + + +declDefDecoder : BD.Decoder DeclDef +declDefDecoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.map3 DeclDefSpace + spaceDecoder + BD.int + BD.int + + 1 -> + BD.map2 DeclDefEquals + BD.int + BD.int + + 2 -> + BD.map3 DeclDefType + typeDecoder + BD.int + BD.int + + 3 -> + BD.map3 DeclDefArg + patternDecoder + BD.int + BD.int + + 4 -> + BD.map3 DeclDefBody + exprDecoder + BD.int + BD.int + + 5 -> + BD.map2 DeclDefNameRepeat + BD.int + BD.int + + 6 -> + BD.map3 DeclDefNameMatch + BD.string + BD.int + BD.int + + 7 -> + BD.map2 DeclDefIndentType + BD.int + BD.int + + 8 -> + BD.map2 DeclDefIndentEquals + BD.int + BD.int + + 9 -> + BD.map2 DeclDefIndentBody + BD.int + BD.int + + _ -> + BD.fail + ) + + +typeEncoder : Type -> BE.Encoder +typeEncoder type_ = + case type_ of + TRecord record row col -> + BE.sequence + [ BE.unsignedInt8 0 + , tRecordEncoder record + , BE.int row + , BE.int col + ] + + TTuple tuple row col -> + BE.sequence + [ BE.unsignedInt8 1 + , tTupleEncoder tuple + , BE.int row + , BE.int col + ] + + TStart row col -> + BE.sequence + [ BE.unsignedInt8 2 + , BE.int row + , BE.int col + ] + + TSpace space row col -> + BE.sequence + [ BE.unsignedInt8 3 + , spaceEncoder space + , BE.int row + , BE.int col + ] + + TIndentStart row col -> + BE.sequence + [ BE.unsignedInt8 4 + , BE.int row + , BE.int col + ] + + +typeDecoder : BD.Decoder Type +typeDecoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.map3 TRecord + tRecordDecoder + BD.int + BD.int + + 1 -> + BD.map3 TTuple + tTupleDecoder + BD.int + BD.int + + 2 -> + BD.map2 TStart + BD.int + BD.int + + 3 -> + BD.map3 TSpace + spaceDecoder + BD.int + BD.int + + 4 -> + BD.map2 TIndentStart + BD.int + BD.int + + _ -> + BD.fail + ) + + +patternEncoder : Pattern -> BE.Encoder +patternEncoder pattern = + case pattern of + PRecord record row col -> + BE.sequence + [ BE.unsignedInt8 0 + , pRecordEncoder record + , BE.int row + , BE.int col + ] + + PTuple tuple row col -> + BE.sequence + [ BE.unsignedInt8 1 + , pTupleEncoder tuple + , BE.int row + , BE.int col + ] + + PList list row col -> + BE.sequence + [ BE.unsignedInt8 2 + , pListEncoder list + , BE.int row + , BE.int col + ] + + PStart row col -> + BE.sequence + [ BE.unsignedInt8 3 + , BE.int row + , BE.int col + ] + + PChar char row col -> + BE.sequence + [ BE.unsignedInt8 4 + , charEncoder char + , BE.int row + , BE.int col + ] + + PString string row col -> + BE.sequence + [ BE.unsignedInt8 5 + , stringEncoder string + , BE.int row + , BE.int col + ] + + PNumber number row col -> + BE.sequence + [ BE.unsignedInt8 6 + , numberEncoder number + , BE.int row + , BE.int col + ] + + PFloat width row col -> + BE.sequence + [ BE.unsignedInt8 7 + , BE.int width + , BE.int row + , BE.int col + ] + + PAlias row col -> + BE.sequence + [ BE.unsignedInt8 8 + , BE.int row + , BE.int col + ] + + PWildcardNotVar name width row col -> + BE.sequence + [ BE.unsignedInt8 9 + , BE.string name + , BE.int width + , BE.int row + , BE.int col + ] + + PWildcardReservedWord name width row col -> + BE.sequence + [ BE.unsignedInt8 10 + , BE.string name + , BE.int width + , BE.int row + , BE.int col + ] + + PSpace space row col -> + BE.sequence + [ BE.unsignedInt8 11 + , spaceEncoder space + , BE.int row + , BE.int col + ] + + PIndentStart row col -> + BE.sequence + [ BE.unsignedInt8 12 + , BE.int row + , BE.int col + ] + + PIndentAlias row col -> + BE.sequence + [ BE.unsignedInt8 13 + , BE.int row + , BE.int col + ] + + +patternDecoder : BD.Decoder Pattern +patternDecoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.map3 PRecord + pRecordDecoder + BD.int + BD.int + + 1 -> + BD.map3 PTuple + pTupleDecoder + BD.int + BD.int + + 2 -> + BD.map3 PList + pListDecoder + BD.int + BD.int + + 3 -> + BD.map2 PStart + BD.int + BD.int + + 4 -> + BD.map3 PChar + charDecoder + BD.int + BD.int + + 5 -> + BD.map3 PString + stringDecoder + BD.int + BD.int + + 6 -> + BD.map3 PNumber + numberDecoder + BD.int + BD.int + + 7 -> + BD.map3 PFloat + BD.int + BD.int + BD.int + + 8 -> + BD.map2 PAlias + BD.int + BD.int + + 9 -> + BD.map4 PWildcardNotVar + BD.string + BD.int + BD.int + BD.int + + 10 -> + BD.map4 PWildcardReservedWord + BD.string + BD.int + BD.int + BD.int + + 11 -> + BD.map3 PSpace + spaceDecoder + BD.int + BD.int + + 12 -> + BD.map2 PIndentStart + BD.int + BD.int + + 13 -> + BD.map2 PIndentAlias + BD.int + BD.int + + _ -> + BD.fail + ) + + +exprEncoder : Expr -> BE.Encoder +exprEncoder expr = + case expr of + Let let_ row col -> + BE.sequence + [ BE.unsignedInt8 0 + , letEncoder let_ + , BE.int row + , BE.int col + ] + + Case case_ row col -> + BE.sequence + [ BE.unsignedInt8 1 + , caseEncoder case_ + , BE.int row + , BE.int col + ] + + If if_ row col -> + BE.sequence + [ BE.unsignedInt8 2 + , ifEncoder if_ + , BE.int row + , BE.int col + ] + + List list row col -> + BE.sequence + [ BE.unsignedInt8 3 + , listEncoder list + , BE.int row + , BE.int col + ] + + Record record row col -> + BE.sequence + [ BE.unsignedInt8 4 + , recordEncoder record + , BE.int row + , BE.int col + ] + + Tuple tuple row col -> + BE.sequence + [ BE.unsignedInt8 5 + , tupleEncoder tuple + , BE.int row + , BE.int col + ] + + Func func row col -> + BE.sequence + [ BE.unsignedInt8 6 + , funcEncoder func + , BE.int row + , BE.int col + ] + + Dot row col -> + BE.sequence + [ BE.unsignedInt8 7 + , BE.int row + , BE.int col + ] + + Access row col -> + BE.sequence + [ BE.unsignedInt8 8 + , BE.int row + , BE.int col + ] + + OperatorRight op row col -> + BE.sequence + [ BE.unsignedInt8 9 + , BE.string op + , BE.int row + , BE.int col + ] + + OperatorReserved operator row col -> + BE.sequence + [ BE.unsignedInt8 10 + , Symbol.badOperatorEncoder operator + , BE.int row + , BE.int col + ] + + Start row col -> + BE.sequence + [ BE.unsignedInt8 11 + , BE.int row + , BE.int col + ] + + Char char row col -> + BE.sequence + [ BE.unsignedInt8 12 + , charEncoder char + , BE.int row + , BE.int col + ] + + String_ string row col -> + BE.sequence + [ BE.unsignedInt8 13 + , stringEncoder string + , BE.int row + , BE.int col + ] + + Number number row col -> + BE.sequence + [ BE.unsignedInt8 14 + , numberEncoder number + , BE.int row + , BE.int col + ] + + Space space row col -> + BE.sequence + [ BE.unsignedInt8 15 + , spaceEncoder space + , BE.int row + , BE.int col + ] + + EndlessShader row col -> + BE.sequence + [ BE.unsignedInt8 16 + , BE.int row + , BE.int col + ] + + ShaderProblem problem row col -> + BE.sequence + [ BE.unsignedInt8 17 + , BE.string problem + , BE.int row + , BE.int col + ] + + IndentOperatorRight op row col -> + BE.sequence + [ BE.unsignedInt8 18 + , BE.string op + , BE.int row + , BE.int col + ] + + +exprDecoder : BD.Decoder Expr +exprDecoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.map3 Let + letDecoder + BD.int + BD.int + + 1 -> + BD.map3 Case + caseDecoder + BD.int + BD.int + + 2 -> + BD.map3 If + ifDecoder + BD.int + BD.int + + 3 -> + BD.map3 List + listDecoder + BD.int + BD.int + + 4 -> + BD.map3 Record + recordDecoder + BD.int + BD.int + + 5 -> + BD.map3 Tuple + tupleDecoder + BD.int + BD.int + + 6 -> + BD.map3 Func + funcDecoder + BD.int + BD.int + + 7 -> + BD.map2 Dot + BD.int + BD.int + + 8 -> + BD.map2 Access + BD.int + BD.int + + 9 -> + BD.map3 OperatorRight + BD.string + BD.int + BD.int + + 10 -> + BD.map3 OperatorReserved + Symbol.badOperatorDecoder + BD.int + BD.int + + 11 -> + BD.map2 Start + BD.int + BD.int + + 12 -> + BD.map3 Char + charDecoder + BD.int + BD.int + + 13 -> + BD.map3 String_ + stringDecoder + BD.int + BD.int + + 14 -> + BD.map3 Number + numberDecoder + BD.int + BD.int + + 15 -> + BD.map3 Space + spaceDecoder + BD.int + BD.int + + 16 -> + BD.map2 EndlessShader + BD.int + BD.int + + 17 -> + BD.map3 ShaderProblem + BD.string + BD.int + BD.int + + 18 -> + BD.map3 IndentOperatorRight + BD.string + BD.int + BD.int + + _ -> + BD.fail + ) + + +letEncoder : Let -> BE.Encoder +letEncoder let_ = + case let_ of + LetSpace space row col -> + BE.sequence + [ BE.unsignedInt8 0 + , spaceEncoder space + , BE.int row + , BE.int col + ] + + LetIn row col -> + BE.sequence + [ BE.unsignedInt8 1 + , BE.int row + , BE.int col + ] + + LetDefAlignment int row col -> + BE.sequence + [ BE.unsignedInt8 2 + , BE.int int + , BE.int row + , BE.int col + ] + + LetDefName row col -> + BE.sequence + [ BE.unsignedInt8 3 + , BE.int row + , BE.int col + ] + + LetDef name def row col -> + BE.sequence + [ BE.unsignedInt8 4 + , BE.string name + , defEncoder def + , BE.int row + , BE.int col + ] + + LetDestruct destruct row col -> + BE.sequence + [ BE.unsignedInt8 5 + , destructEncoder destruct + , BE.int row + , BE.int col + ] + + LetBody expr row col -> + BE.sequence + [ BE.unsignedInt8 6 + , exprEncoder expr + , BE.int row + , BE.int col + ] + + LetIndentDef row col -> + BE.sequence + [ BE.unsignedInt8 7 + , BE.int row + , BE.int col + ] + + LetIndentIn row col -> + BE.sequence + [ BE.unsignedInt8 8 + , BE.int row + , BE.int col + ] + + LetIndentBody row col -> + BE.sequence + [ BE.unsignedInt8 9 + , BE.int row + , BE.int col + ] + + +letDecoder : BD.Decoder Let +letDecoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.map3 LetSpace + spaceDecoder + BD.int + BD.int + + 1 -> + BD.map2 LetIn + BD.int + BD.int + + 2 -> + BD.map3 LetDefAlignment + BD.int + BD.int + BD.int + + 3 -> + BD.map2 LetDefName + BD.int + BD.int + + 4 -> + BD.map4 LetDef + BD.string + defDecoder + BD.int + BD.int + + 5 -> + BD.map3 LetDestruct + destructDecoder + BD.int + BD.int + + 6 -> + BD.map3 LetBody + exprDecoder + BD.int + BD.int + + 7 -> + BD.map2 LetIndentDef + BD.int + BD.int + + 8 -> + BD.map2 LetIndentIn + BD.int + BD.int + + 9 -> + BD.map2 LetIndentBody + BD.int + BD.int + + _ -> + BD.fail + ) + + +caseEncoder : Case -> BE.Encoder +caseEncoder case_ = + case case_ of + CaseSpace space row col -> + BE.sequence + [ BE.unsignedInt8 0 + , spaceEncoder space + , BE.int row + , BE.int col + ] + + CaseOf row col -> + BE.sequence + [ BE.unsignedInt8 1 + , BE.int row + , BE.int col + ] + + CasePattern pattern row col -> + BE.sequence + [ BE.unsignedInt8 2 + , patternEncoder pattern + , BE.int row + , BE.int col + ] + + CaseArrow row col -> + BE.sequence + [ BE.unsignedInt8 3 + , BE.int row + , BE.int col + ] + + CaseExpr expr row col -> + BE.sequence + [ BE.unsignedInt8 4 + , exprEncoder expr + , BE.int row + , BE.int col + ] + + CaseBranch expr row col -> + BE.sequence + [ BE.unsignedInt8 5 + , exprEncoder expr + , BE.int row + , BE.int col + ] + + CaseIndentOf row col -> + BE.sequence + [ BE.unsignedInt8 6 + , BE.int row + , BE.int col + ] + + CaseIndentExpr row col -> + BE.sequence + [ BE.unsignedInt8 7 + , BE.int row + , BE.int col + ] + + CaseIndentPattern row col -> + BE.sequence + [ BE.unsignedInt8 8 + , BE.int row + , BE.int col + ] + + CaseIndentArrow row col -> + BE.sequence + [ BE.unsignedInt8 9 + , BE.int row + , BE.int col + ] + + CaseIndentBranch row col -> + BE.sequence + [ BE.unsignedInt8 10 + , BE.int row + , BE.int col + ] + + CasePatternAlignment indent row col -> + BE.sequence + [ BE.unsignedInt8 11 + , BE.int indent + , BE.int row + , BE.int col + ] + + +caseDecoder : BD.Decoder Case +caseDecoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.map3 CaseSpace + spaceDecoder + BD.int + BD.int + + 1 -> + BD.map2 CaseOf + BD.int + BD.int + + 2 -> + BD.map3 CasePattern + patternDecoder + BD.int + BD.int + + 3 -> + BD.map2 CaseArrow + BD.int + BD.int + + 4 -> + BD.map3 CaseExpr + exprDecoder + BD.int + BD.int + + 5 -> + BD.map3 CaseBranch + exprDecoder + BD.int + BD.int + + 6 -> + BD.map2 CaseIndentOf + BD.int + BD.int + + 7 -> + BD.map2 CaseIndentExpr + BD.int + BD.int + + 8 -> + BD.map2 CaseIndentPattern + BD.int + BD.int + + 9 -> + BD.map2 CaseIndentArrow + BD.int + BD.int + + 10 -> + BD.map2 CaseIndentBranch + BD.int + BD.int + + 11 -> + BD.map3 CasePatternAlignment + BD.int + BD.int + BD.int + + _ -> + BD.fail + ) + + +ifEncoder : If -> BE.Encoder +ifEncoder if_ = + case if_ of + IfSpace space row col -> + BE.sequence + [ BE.unsignedInt8 0 + , spaceEncoder space + , BE.int row + , BE.int col + ] + + IfThen row col -> + BE.sequence + [ BE.unsignedInt8 1 + , BE.int row + , BE.int col + ] + + IfElse row col -> + BE.sequence + [ BE.unsignedInt8 2 + , BE.int row + , BE.int col + ] + + IfElseBranchStart row col -> + BE.sequence + [ BE.unsignedInt8 3 + , BE.int row + , BE.int col + ] + + IfCondition expr row col -> + BE.sequence + [ BE.unsignedInt8 4 + , exprEncoder expr + , BE.int row + , BE.int col + ] + + IfThenBranch expr row col -> + BE.sequence + [ BE.unsignedInt8 5 + , exprEncoder expr + , BE.int row + , BE.int col + ] + + IfElseBranch expr row col -> + BE.sequence + [ BE.unsignedInt8 6 + , exprEncoder expr + , BE.int row + , BE.int col + ] + + IfIndentCondition row col -> + BE.sequence + [ BE.unsignedInt8 7 + , BE.int row + , BE.int col + ] + + IfIndentThen row col -> + BE.sequence + [ BE.unsignedInt8 8 + , BE.int row + , BE.int col + ] + + IfIndentThenBranch row col -> + BE.sequence + [ BE.unsignedInt8 9 + , BE.int row + , BE.int col + ] + + IfIndentElseBranch row col -> + BE.sequence + [ BE.unsignedInt8 10 + , BE.int row + , BE.int col + ] + + IfIndentElse row col -> + BE.sequence + [ BE.unsignedInt8 11 + , BE.int row + , BE.int col + ] + + +ifDecoder : BD.Decoder If +ifDecoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.map3 IfSpace + spaceDecoder + BD.int + BD.int + + 1 -> + BD.map2 IfThen + BD.int + BD.int + + 2 -> + BD.map2 IfElse + BD.int + BD.int + + 3 -> + BD.map2 IfElseBranchStart + BD.int + BD.int + + 4 -> + BD.map3 IfCondition + exprDecoder + BD.int + BD.int + + 5 -> + BD.map3 IfThenBranch + exprDecoder + BD.int + BD.int + + 6 -> + BD.map3 IfElseBranch + exprDecoder + BD.int + BD.int + + 7 -> + BD.map2 IfIndentCondition + BD.int + BD.int + + 8 -> + BD.map2 IfIndentThen + BD.int + BD.int + + 9 -> + BD.map2 IfIndentThenBranch + BD.int + BD.int + + 10 -> + BD.map2 IfIndentElseBranch + BD.int + BD.int + + 11 -> + BD.map2 IfIndentElse + BD.int + BD.int + + _ -> + BD.fail + ) + + +listEncoder : List_ -> BE.Encoder +listEncoder list_ = + case list_ of + ListSpace space row col -> + BE.sequence + [ BE.unsignedInt8 0 + , spaceEncoder space + , BE.int row + , BE.int col + ] + + ListOpen row col -> + BE.sequence + [ BE.unsignedInt8 1 + , BE.int row + , BE.int col + ] + + ListExpr expr row col -> + BE.sequence + [ BE.unsignedInt8 2 + , exprEncoder expr + , BE.int row + , BE.int col + ] + + ListEnd row col -> + BE.sequence + [ BE.unsignedInt8 3 + , BE.int row + , BE.int col + ] + + ListIndentOpen row col -> + BE.sequence + [ BE.unsignedInt8 4 + , BE.int row + , BE.int col + ] + + ListIndentEnd row col -> + BE.sequence + [ BE.unsignedInt8 5 + , BE.int row + , BE.int col + ] + + ListIndentExpr row col -> + BE.sequence + [ BE.unsignedInt8 6 + , BE.int row + , BE.int col + ] + + +listDecoder : BD.Decoder List_ +listDecoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.map3 ListSpace + spaceDecoder + BD.int + BD.int + + 1 -> + BD.map2 ListOpen + BD.int + BD.int + + 2 -> + BD.map3 ListExpr + exprDecoder + BD.int + BD.int + + 3 -> + BD.map2 ListEnd + BD.int + BD.int + + 4 -> + BD.map2 ListIndentOpen + BD.int + BD.int + + 5 -> + BD.map2 ListIndentEnd + BD.int + BD.int + + 6 -> + BD.map2 ListIndentExpr + BD.int + BD.int + + _ -> + BD.fail + ) + + +recordEncoder : Record -> BE.Encoder +recordEncoder record = + case record of + RecordOpen row col -> + BE.sequence + [ BE.unsignedInt8 0 + , BE.int row + , BE.int col + ] + + RecordEnd row col -> + BE.sequence + [ BE.unsignedInt8 1 + , BE.int row + , BE.int col + ] + + RecordField row col -> + BE.sequence + [ BE.unsignedInt8 2 + , BE.int row + , BE.int col + ] + + RecordEquals row col -> + BE.sequence + [ BE.unsignedInt8 3 + , BE.int row + , BE.int col + ] + + RecordExpr expr row col -> + BE.sequence + [ BE.unsignedInt8 4 + , exprEncoder expr + , BE.int row + , BE.int col + ] + + RecordSpace space row col -> + BE.sequence + [ BE.unsignedInt8 5 + , spaceEncoder space + , BE.int row + , BE.int col + ] + + RecordIndentOpen row col -> + BE.sequence + [ BE.unsignedInt8 6 + , BE.int row + , BE.int col + ] + + RecordIndentEnd row col -> + BE.sequence + [ BE.unsignedInt8 7 + , BE.int row + , BE.int col + ] + + RecordIndentField row col -> + BE.sequence + [ BE.unsignedInt8 8 + , BE.int row + , BE.int col + ] + + RecordIndentEquals row col -> + BE.sequence + [ BE.unsignedInt8 9 + , BE.int row + , BE.int col + ] + + RecordIndentExpr row col -> + BE.sequence + [ BE.unsignedInt8 10 + , BE.int row + , BE.int col + ] + + +recordDecoder : BD.Decoder Record +recordDecoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.map2 RecordOpen + BD.int + BD.int + + 1 -> + BD.map2 RecordEnd + BD.int + BD.int + + 2 -> + BD.map2 RecordField + BD.int + BD.int + + 3 -> + BD.map2 RecordEquals + BD.int + BD.int + + 4 -> + BD.map3 RecordExpr + exprDecoder + BD.int + BD.int + + 5 -> + BD.map3 RecordSpace + spaceDecoder + BD.int + BD.int + + 6 -> + BD.map2 RecordIndentOpen + BD.int + BD.int + + 7 -> + BD.map2 RecordIndentEnd + BD.int + BD.int + + 8 -> + BD.map2 RecordIndentField + BD.int + BD.int + + 9 -> + BD.map2 RecordIndentEquals + BD.int + BD.int + + 10 -> + BD.map2 RecordIndentExpr + BD.int + BD.int + + _ -> + BD.fail + ) + + +tupleEncoder : Tuple -> BE.Encoder +tupleEncoder tuple = + case tuple of + TupleExpr expr row col -> + BE.sequence + [ BE.unsignedInt8 0 + , exprEncoder expr + , BE.int row + , BE.int col + ] + + TupleSpace space row col -> + BE.sequence + [ BE.unsignedInt8 1 + , spaceEncoder space + , BE.int row + , BE.int col + ] + + TupleEnd row col -> + BE.sequence + [ BE.unsignedInt8 2 + , BE.int row + , BE.int col + ] + + TupleOperatorClose row col -> + BE.sequence + [ BE.unsignedInt8 3 + , BE.int row + , BE.int col + ] + + TupleOperatorReserved operator row col -> + BE.sequence + [ BE.unsignedInt8 4 + , Symbol.badOperatorEncoder operator + , BE.int row + , BE.int col + ] + + TupleIndentExpr1 row col -> + BE.sequence + [ BE.unsignedInt8 5 + , BE.int row + , BE.int col + ] + + TupleIndentExprN row col -> + BE.sequence + [ BE.unsignedInt8 6 + , BE.int row + , BE.int col + ] + + TupleIndentEnd row col -> + BE.sequence + [ BE.unsignedInt8 7 + , BE.int row + , BE.int col + ] + + +tupleDecoder : BD.Decoder Tuple +tupleDecoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.map3 TupleExpr + exprDecoder + BD.int + BD.int + + 1 -> + BD.map3 TupleSpace + spaceDecoder + BD.int + BD.int + + 2 -> + BD.map2 TupleEnd + BD.int + BD.int + + 3 -> + BD.map2 TupleOperatorClose + BD.int + BD.int + + 4 -> + BD.map3 TupleOperatorReserved + Symbol.badOperatorDecoder + BD.int + BD.int + + 5 -> + BD.map2 TupleIndentExpr1 + BD.int + BD.int + + 6 -> + BD.map2 TupleIndentExprN + BD.int + BD.int + + 7 -> + BD.map2 TupleIndentEnd + BD.int + BD.int + + _ -> + BD.fail + ) + + +funcEncoder : Func -> BE.Encoder +funcEncoder func = + case func of + FuncSpace space row col -> + BE.sequence + [ BE.unsignedInt8 0 + , spaceEncoder space + , BE.int row + , BE.int col + ] + + FuncArg pattern row col -> + BE.sequence + [ BE.unsignedInt8 1 + , patternEncoder pattern + , BE.int row + , BE.int col + ] + + FuncBody expr row col -> + BE.sequence + [ BE.unsignedInt8 2 + , exprEncoder expr + , BE.int row + , BE.int col + ] + + FuncArrow row col -> + BE.sequence + [ BE.unsignedInt8 3 + , BE.int row + , BE.int col + ] + + FuncIndentArg row col -> + BE.sequence + [ BE.unsignedInt8 4 + , BE.int row + , BE.int col + ] + + FuncIndentArrow row col -> + BE.sequence + [ BE.unsignedInt8 5 + , BE.int row + , BE.int col + ] + + FuncIndentBody row col -> + BE.sequence + [ BE.unsignedInt8 6 + , BE.int row + , BE.int col + ] + + +funcDecoder : BD.Decoder Func +funcDecoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.map3 FuncSpace + spaceDecoder + BD.int + BD.int + + 1 -> + BD.map3 FuncArg + patternDecoder + BD.int + BD.int + + 2 -> + BD.map3 FuncBody + exprDecoder + BD.int + BD.int + + 3 -> + BD.map2 FuncArrow + BD.int + BD.int + + 4 -> + BD.map2 FuncIndentArg + BD.int + BD.int + + 5 -> + BD.map2 FuncIndentArrow + BD.int + BD.int + + 6 -> + BD.map2 FuncIndentBody + BD.int + BD.int + + _ -> + BD.fail + ) + + +charEncoder : Char -> BE.Encoder +charEncoder char = + case char of + CharEndless -> + BE.unsignedInt8 0 + + CharEscape escape -> + BE.sequence + [ BE.unsignedInt8 1 + , escapeEncoder escape + ] + + CharNotString width -> + BE.sequence + [ BE.unsignedInt8 2 + , BE.int width + ] + + +charDecoder : BD.Decoder Char +charDecoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.succeed CharEndless + + 1 -> + BD.map CharEscape escapeDecoder + + 2 -> + BD.map CharNotString BD.int + + _ -> + BD.fail + ) + + +stringEncoder : String_ -> BE.Encoder +stringEncoder string_ = + case string_ of + StringEndless_Single -> + BE.unsignedInt8 0 + + StringEndless_Multi -> + BE.unsignedInt8 1 + + StringEscape escape -> + BE.sequence + [ BE.unsignedInt8 2 + , escapeEncoder escape + ] + + +stringDecoder : BD.Decoder String_ +stringDecoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.succeed StringEndless_Single + + 1 -> + BD.succeed StringEndless_Multi + + 2 -> + BD.map StringEscape escapeDecoder + + _ -> + BD.fail + ) + + +numberEncoder : Number -> BE.Encoder +numberEncoder number = + case number of + NumberEnd -> + BE.unsignedInt8 0 + + NumberDot n -> + BE.sequence + [ BE.unsignedInt8 1 + , BE.int n + ] + + NumberHexDigit -> + BE.unsignedInt8 2 + + NumberBinDigit -> + BE.unsignedInt8 3 + + NumberNoLeadingZero -> + BE.unsignedInt8 4 + + NumberNoLeadingOrTrailingUnderscores -> + BE.unsignedInt8 5 + + NumberNoConsecutiveUnderscores -> + BE.unsignedInt8 6 + + NumberNoUnderscoresAdjacentToDecimalOrExponent -> + BE.unsignedInt8 7 + + NumberNoUnderscoresAdjacentToHexadecimalPreFix -> + BE.unsignedInt8 8 + + NumberNoUnderscoresAdjacentToBinaryPreFix -> + BE.unsignedInt8 9 + + +numberDecoder : BD.Decoder Number +numberDecoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.succeed NumberEnd + + 1 -> + BD.map NumberDot BD.int + + 2 -> + BD.succeed NumberHexDigit + + 3 -> + BD.succeed NumberBinDigit + + 4 -> + BD.succeed NumberNoLeadingZero + + 5 -> + BD.succeed NumberNoLeadingOrTrailingUnderscores + + 6 -> + BD.succeed NumberNoConsecutiveUnderscores + + 7 -> + BD.succeed NumberNoUnderscoresAdjacentToDecimalOrExponent + + 8 -> + BD.succeed NumberNoUnderscoresAdjacentToHexadecimalPreFix + + 9 -> + BD.succeed NumberNoUnderscoresAdjacentToBinaryPreFix + + _ -> + BD.fail + ) + + +escapeEncoder : Escape -> BE.Encoder +escapeEncoder escape = + case escape of + EscapeUnknown -> + BE.unsignedInt8 0 + + BadUnicodeFormat width -> + BE.sequence + [ BE.unsignedInt8 1 + , BE.int width + ] + + BadUnicodeCode width -> + BE.sequence + [ BE.unsignedInt8 2 + , BE.int width + ] + + BadUnicodeLength width numDigits badCode -> + BE.sequence + [ BE.unsignedInt8 3 + , BE.int width + , BE.int numDigits + , BE.int badCode + ] + + +escapeDecoder : BD.Decoder Escape +escapeDecoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.succeed EscapeUnknown + + 1 -> + BD.map BadUnicodeFormat BD.int + + 2 -> + BD.map BadUnicodeCode BD.int + + 3 -> + BD.map3 BadUnicodeLength + BD.int + BD.int + BD.int + + _ -> + BD.fail + ) + + +defEncoder : Def -> BE.Encoder +defEncoder def = + case def of + DefSpace space row col -> + BE.sequence + [ BE.unsignedInt8 0 + , spaceEncoder space + , BE.int row + , BE.int col + ] + + DefType tipe row col -> + BE.sequence + [ BE.unsignedInt8 1 + , typeEncoder tipe + , BE.int row + , BE.int col + ] + + DefNameRepeat row col -> + BE.sequence + [ BE.unsignedInt8 2 + , BE.int row + , BE.int col + ] + + DefNameMatch name row col -> + BE.sequence + [ BE.unsignedInt8 3 + , BE.string name + , BE.int row + , BE.int col + ] + + DefArg pattern row col -> + BE.sequence + [ BE.unsignedInt8 4 + , patternEncoder pattern + , BE.int row + , BE.int col + ] + + DefEquals row col -> + BE.sequence + [ BE.unsignedInt8 5 + , BE.int row + , BE.int col + ] + + DefBody expr row col -> + BE.sequence + [ BE.unsignedInt8 6 + , exprEncoder expr + , BE.int row + , BE.int col + ] + + DefIndentEquals row col -> + BE.sequence + [ BE.unsignedInt8 7 + , BE.int row + , BE.int col + ] + + DefIndentType row col -> + BE.sequence + [ BE.unsignedInt8 8 + , BE.int row + , BE.int col + ] + + DefIndentBody row col -> + BE.sequence + [ BE.unsignedInt8 9 + , BE.int row + , BE.int col + ] + + DefAlignment indent row col -> + BE.sequence + [ BE.unsignedInt8 10 + , BE.int indent + , BE.int row + , BE.int col + ] + + +defDecoder : BD.Decoder Def +defDecoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.map3 DefSpace + spaceDecoder + BD.int + BD.int + + 1 -> + BD.map3 DefType + typeDecoder + BD.int + BD.int + + 2 -> + BD.map2 DefNameRepeat + BD.int + BD.int + + 3 -> + BD.map3 DefNameMatch + BD.string + BD.int + BD.int + + 4 -> + BD.map3 DefArg + patternDecoder + BD.int + BD.int + + 5 -> + BD.map2 DefEquals + BD.int + BD.int + + 6 -> + BD.map3 DefBody + exprDecoder + BD.int + BD.int + + 7 -> + BD.map2 DefIndentEquals + BD.int + BD.int + + 8 -> + BD.map2 DefIndentType + BD.int + BD.int + + 9 -> + BD.map2 DefIndentBody + BD.int + BD.int + + 10 -> + BD.map3 DefAlignment + BD.int + BD.int + BD.int + + _ -> + BD.fail + ) + + +destructEncoder : Destruct -> BE.Encoder +destructEncoder destruct = + case destruct of + DestructSpace space row col -> + BE.sequence + [ BE.unsignedInt8 0 + , spaceEncoder space + , BE.int row + , BE.int col + ] + + DestructPattern pattern row col -> + BE.sequence + [ BE.unsignedInt8 1 + , patternEncoder pattern + , BE.int row + , BE.int col + ] + + DestructEquals row col -> + BE.sequence + [ BE.unsignedInt8 2 + , BE.int row + , BE.int col + ] + + DestructBody expr row col -> + BE.sequence + [ BE.unsignedInt8 3 + , exprEncoder expr + , BE.int row + , BE.int col + ] + + DestructIndentEquals row col -> + BE.sequence + [ BE.unsignedInt8 4 + , BE.int row + , BE.int col + ] + + DestructIndentBody row col -> + BE.sequence + [ BE.unsignedInt8 5 + , BE.int row + , BE.int col + ] + + +destructDecoder : BD.Decoder Destruct +destructDecoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.map3 DestructSpace + spaceDecoder + BD.int + BD.int + + 1 -> + BD.map3 DestructPattern + patternDecoder + BD.int + BD.int + + 2 -> + BD.map2 DestructEquals + BD.int + BD.int + + 3 -> + BD.map3 DestructBody + exprDecoder + BD.int + BD.int + + 4 -> + BD.map2 DestructIndentEquals + BD.int + BD.int + + 5 -> + BD.map2 DestructIndentBody + BD.int + BD.int + + _ -> + BD.fail + ) + + +pRecordEncoder : PRecord -> BE.Encoder +pRecordEncoder pRecord = + case pRecord of + PRecordOpen row col -> + BE.sequence + [ BE.unsignedInt8 0 + , BE.int row + , BE.int col + ] + + PRecordEnd row col -> + BE.sequence + [ BE.unsignedInt8 1 + , BE.int row + , BE.int col + ] + + PRecordField row col -> + BE.sequence + [ BE.unsignedInt8 2 + , BE.int row + , BE.int col + ] + + PRecordSpace space row col -> + BE.sequence + [ BE.unsignedInt8 3 + , spaceEncoder space + , BE.int row + , BE.int col + ] + + PRecordIndentOpen row col -> + BE.sequence + [ BE.unsignedInt8 4 + , BE.int row + , BE.int col + ] + + PRecordIndentEnd row col -> + BE.sequence + [ BE.unsignedInt8 5 + , BE.int row + , BE.int col + ] + + PRecordIndentField row col -> + BE.sequence + [ BE.unsignedInt8 6 + , BE.int row + , BE.int col + ] + + +pRecordDecoder : BD.Decoder PRecord +pRecordDecoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.map2 PRecordOpen + BD.int + BD.int + + 1 -> + BD.map2 PRecordEnd + BD.int + BD.int + + 2 -> + BD.map2 PRecordField + BD.int + BD.int + + 3 -> + BD.map3 PRecordSpace + spaceDecoder + BD.int + BD.int + + 4 -> + BD.map2 PRecordIndentOpen + BD.int + BD.int + + 5 -> + BD.map2 PRecordIndentEnd + BD.int + BD.int + + 6 -> + BD.map2 PRecordIndentField + BD.int + BD.int + + _ -> + BD.fail + ) + + +pTupleEncoder : PTuple -> BE.Encoder +pTupleEncoder pTuple = + case pTuple of + PTupleOpen row col -> + BE.sequence + [ BE.unsignedInt8 0 + , BE.int row + , BE.int col + ] + + PTupleEnd row col -> + BE.sequence + [ BE.unsignedInt8 1 + , BE.int row + , BE.int col + ] + + PTupleExpr pattern row col -> + BE.sequence + [ BE.unsignedInt8 2 + , patternEncoder pattern + , BE.int row + , BE.int col + ] + + PTupleSpace space row col -> + BE.sequence + [ BE.unsignedInt8 3 + , spaceEncoder space + , BE.int row + , BE.int col + ] + + PTupleIndentEnd row col -> + BE.sequence + [ BE.unsignedInt8 4 + , BE.int row + , BE.int col + ] + + PTupleIndentExpr1 row col -> + BE.sequence + [ BE.unsignedInt8 5 + , BE.int row + , BE.int col + ] + + PTupleIndentExprN row col -> + BE.sequence + [ BE.unsignedInt8 6 + , BE.int row + , BE.int col + ] + + +pTupleDecoder : BD.Decoder PTuple +pTupleDecoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.map2 PTupleOpen + BD.int + BD.int + + 1 -> + BD.map2 PTupleEnd + BD.int + BD.int + + 2 -> + BD.map3 PTupleExpr + patternDecoder + BD.int + BD.int + + 3 -> + BD.map3 PTupleSpace + spaceDecoder + BD.int + BD.int + + 4 -> + BD.map2 PTupleIndentEnd + BD.int + BD.int + + 5 -> + BD.map2 PTupleIndentExpr1 + BD.int + BD.int + + 6 -> + BD.map2 PTupleIndentExprN + BD.int + BD.int + + _ -> + BD.fail + ) + + +pListEncoder : PList -> BE.Encoder +pListEncoder pList = + case pList of + PListOpen row col -> + BE.sequence + [ BE.unsignedInt8 0 + , BE.int row + , BE.int col + ] + + PListEnd row col -> + BE.sequence + [ BE.unsignedInt8 1 + , BE.int row + , BE.int col + ] + + PListExpr pattern row col -> + BE.sequence + [ BE.unsignedInt8 2 + , patternEncoder pattern + , BE.int row + , BE.int col + ] + + PListSpace space row col -> + BE.sequence + [ BE.unsignedInt8 3 + , spaceEncoder space + , BE.int row + , BE.int col + ] + + PListIndentOpen row col -> + BE.sequence + [ BE.unsignedInt8 4 + , BE.int row + , BE.int col + ] + + PListIndentEnd row col -> + BE.sequence + [ BE.unsignedInt8 5 + , BE.int row + , BE.int col + ] + + PListIndentExpr row col -> + BE.sequence + [ BE.unsignedInt8 6 + , BE.int row + , BE.int col + ] + + +pListDecoder : BD.Decoder PList +pListDecoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.map2 PListOpen + BD.int + BD.int + + 1 -> + BD.map2 PListEnd + BD.int + BD.int + + 2 -> + BD.map3 PListExpr + patternDecoder + BD.int + BD.int + + 3 -> + BD.map3 PListSpace + spaceDecoder + BD.int + BD.int + + 4 -> + BD.map2 PListIndentOpen + BD.int + BD.int + + 5 -> + BD.map2 PListIndentEnd + BD.int + BD.int + + 6 -> + BD.map2 PListIndentExpr + BD.int + BD.int + + _ -> + BD.fail + ) + + +tRecordEncoder : TRecord -> BE.Encoder +tRecordEncoder tRecord = + case tRecord of + TRecordOpen row col -> + BE.sequence + [ BE.unsignedInt8 0 + , BE.int row + , BE.int col + ] + + TRecordEnd row col -> + BE.sequence + [ BE.unsignedInt8 1 + , BE.int row + , BE.int col + ] + + TRecordField row col -> + BE.sequence + [ BE.unsignedInt8 2 + , BE.int row + , BE.int col + ] + + TRecordColon row col -> + BE.sequence + [ BE.unsignedInt8 3 + , BE.int row + , BE.int col + ] + + TRecordType tipe row col -> + BE.sequence + [ BE.unsignedInt8 4 + , typeEncoder tipe + , BE.int row + , BE.int col + ] + + TRecordSpace space row col -> + BE.sequence + [ BE.unsignedInt8 5 + , spaceEncoder space + , BE.int row + , BE.int col + ] + + TRecordIndentOpen row col -> + BE.sequence + [ BE.unsignedInt8 6 + , BE.int row + , BE.int col + ] + + TRecordIndentField row col -> + BE.sequence + [ BE.unsignedInt8 7 + , BE.int row + , BE.int col + ] + + TRecordIndentColon row col -> + BE.sequence + [ BE.unsignedInt8 8 + , BE.int row + , BE.int col + ] + + TRecordIndentType row col -> + BE.sequence + [ BE.unsignedInt8 9 + , BE.int row + , BE.int col + ] + + TRecordIndentEnd row col -> + BE.sequence + [ BE.unsignedInt8 10 + , BE.int row + , BE.int col + ] + + +tRecordDecoder : BD.Decoder TRecord +tRecordDecoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.map2 TRecordOpen + BD.int + BD.int + + 1 -> + BD.map2 TRecordEnd + BD.int + BD.int + + 2 -> + BD.map2 TRecordField + BD.int + BD.int + + 3 -> + BD.map2 TRecordColon + BD.int + BD.int + + 4 -> + BD.map3 TRecordType + typeDecoder + BD.int + BD.int + + 5 -> + BD.map3 TRecordSpace + spaceDecoder + BD.int + BD.int + + 6 -> + BD.map2 TRecordIndentOpen + BD.int + BD.int + + 7 -> + BD.map2 TRecordIndentField + BD.int + BD.int + + 8 -> + BD.map2 TRecordIndentColon + BD.int + BD.int + + 9 -> + BD.map2 TRecordIndentType + BD.int + BD.int + + 10 -> + BD.map2 TRecordIndentEnd + BD.int + BD.int + + _ -> + BD.fail + ) + + +tTupleEncoder : TTuple -> BE.Encoder +tTupleEncoder tTuple = + case tTuple of + TTupleOpen row col -> + BE.sequence + [ BE.unsignedInt8 0 + , BE.int row + , BE.int col + ] + + TTupleEnd row col -> + BE.sequence + [ BE.unsignedInt8 1 + , BE.int row + , BE.int col + ] + + TTupleType tipe row col -> + BE.sequence + [ BE.unsignedInt8 2 + , typeEncoder tipe + , BE.int row + , BE.int col + ] + + TTupleSpace space row col -> + BE.sequence + [ BE.unsignedInt8 3 + , spaceEncoder space + , BE.int row + , BE.int col + ] + + TTupleIndentType1 row col -> + BE.sequence + [ BE.unsignedInt8 4 + , BE.int row + , BE.int col + ] + + TTupleIndentTypeN row col -> + BE.sequence + [ BE.unsignedInt8 5 + , BE.int row + , BE.int col + ] + + TTupleIndentEnd row col -> + BE.sequence + [ BE.unsignedInt8 6 + , BE.int row + , BE.int col + ] + + +tTupleDecoder : BD.Decoder TTuple +tTupleDecoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.map2 TTupleOpen + BD.int + BD.int + + 1 -> + BD.map2 TTupleEnd + BD.int + BD.int + + 2 -> + BD.map3 TTupleType + typeDecoder + BD.int + BD.int + + 3 -> + BD.map3 TTupleSpace + spaceDecoder + BD.int + BD.int + + 4 -> + BD.map2 TTupleIndentType1 + BD.int + BD.int + + 5 -> + BD.map2 TTupleIndentTypeN + BD.int + BD.int + + 6 -> + BD.map2 TTupleIndentEnd + BD.int + BD.int + + _ -> + BD.fail + ) + + +customTypeEncoder : CustomType -> BE.Encoder +customTypeEncoder customType = + case customType of + CT_Space space row col -> + BE.sequence + [ BE.unsignedInt8 0 + , spaceEncoder space + , BE.int row + , BE.int col + ] + + CT_Name row col -> + BE.sequence + [ BE.unsignedInt8 1 + , BE.int row + , BE.int col + ] + + CT_Equals row col -> + BE.sequence + [ BE.unsignedInt8 2 + , BE.int row + , BE.int col + ] + + CT_Bar row col -> + BE.sequence + [ BE.unsignedInt8 3 + , BE.int row + , BE.int col + ] + + CT_Variant row col -> + BE.sequence + [ BE.unsignedInt8 4 + , BE.int row + , BE.int col + ] + + CT_VariantArg tipe row col -> + BE.sequence + [ BE.unsignedInt8 5 + , typeEncoder tipe + , BE.int row + , BE.int col + ] + + CT_IndentEquals row col -> + BE.sequence + [ BE.unsignedInt8 6 + , BE.int row + , BE.int col + ] + + CT_IndentBar row col -> + BE.sequence + [ BE.unsignedInt8 7 + , BE.int row + , BE.int col + ] + + CT_IndentAfterBar row col -> + BE.sequence + [ BE.unsignedInt8 8 + , BE.int row + , BE.int col + ] + + CT_IndentAfterEquals row col -> + BE.sequence + [ BE.unsignedInt8 9 + , BE.int row + , BE.int col + ] + + +customTypeDecoder : BD.Decoder CustomType +customTypeDecoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.map3 CT_Space + spaceDecoder + BD.int + BD.int + + 1 -> + BD.map2 CT_Name + BD.int + BD.int + + 2 -> + BD.map2 CT_Equals + BD.int + BD.int + + 3 -> + BD.map2 CT_Bar + BD.int + BD.int + + 4 -> + BD.map2 CT_Variant + BD.int + BD.int + + 5 -> + BD.map3 CT_VariantArg + typeDecoder + BD.int + BD.int + + 6 -> + BD.map2 CT_IndentEquals + BD.int + BD.int + + 7 -> + BD.map2 CT_IndentBar + BD.int + BD.int + + 8 -> + BD.map2 CT_IndentAfterBar + BD.int + BD.int + + 9 -> + BD.map2 CT_IndentAfterEquals + BD.int + BD.int + + _ -> + BD.fail + ) + + +typeAliasEncoder : TypeAlias -> BE.Encoder +typeAliasEncoder typeAlias = + case typeAlias of + AliasSpace space row col -> + BE.sequence + [ BE.unsignedInt8 0 + , spaceEncoder space + , BE.int row + , BE.int col + ] + + AliasName row col -> + BE.sequence + [ BE.unsignedInt8 1 + , BE.int row + , BE.int col + ] + + AliasEquals row col -> + BE.sequence + [ BE.unsignedInt8 2 + , BE.int row + , BE.int col + ] + + AliasBody tipe row col -> + BE.sequence + [ BE.unsignedInt8 3 + , typeEncoder tipe + , BE.int row + , BE.int col + ] + + AliasIndentEquals row col -> + BE.sequence + [ BE.unsignedInt8 4 + , BE.int row + , BE.int col + ] + + AliasIndentBody row col -> + BE.sequence + [ BE.unsignedInt8 5 + , BE.int row + , BE.int col + ] + + +typeAliasDecoder : BD.Decoder TypeAlias +typeAliasDecoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.map3 AliasSpace + spaceDecoder + BD.int + BD.int + + 1 -> + BD.map2 AliasName + BD.int + BD.int + + 2 -> + BD.map2 AliasEquals + BD.int + BD.int + + 3 -> + BD.map3 AliasBody + typeDecoder + BD.int + BD.int + + 4 -> + BD.map2 AliasIndentEquals + BD.int + BD.int + + 5 -> + BD.map2 AliasIndentBody + BD.int + BD.int + + _ -> + BD.fail + ) diff --git a/src/Compiler/Reporting/Error/Type.elm b/src/Compiler/Reporting/Error/Type.elm new file mode 100644 index 0000000000..8888a2d80a --- /dev/null +++ b/src/Compiler/Reporting/Error/Type.elm @@ -0,0 +1,3165 @@ +module Compiler.Reporting.Error.Type exposing + ( Category(..) + , Context(..) + , Error(..) + , Expected(..) + , MaybeName(..) + , PCategory(..) + , PContext(..) + , PExpected(..) + , SubContext(..) + , errorDecoder + , errorEncoder + , ptypeReplace + , toReport + , typeReplace + ) + +import Compiler.AST.Canonical as Can +import Compiler.Data.Index as Index +import Compiler.Data.Name exposing (Name) +import Compiler.Reporting.Annotation as A +import Compiler.Reporting.Doc as D +import Compiler.Reporting.Render.Code as Code +import Compiler.Reporting.Render.Type as RT +import Compiler.Reporting.Render.Type.Localizer as L +import Compiler.Reporting.Report as Report +import Compiler.Reporting.Suggest as Suggest +import Compiler.Type.Error as T +import Data.Map as Dict exposing (Dict) +import Utils.Bytes.Decode as BD +import Utils.Bytes.Encode as BE + + + +-- ERRORS + + +type Error + = BadExpr A.Region Category T.Type (Expected T.Type) + | BadPattern A.Region PCategory T.Type (PExpected T.Type) + | InfiniteType A.Region Name T.Type + + + +-- EXPRESSION EXPECTATIONS + + +type Expected tipe + = NoExpectation tipe + | FromContext A.Region Context tipe + | FromAnnotation Name Int SubContext tipe + + +type Context + = ListEntry Index.ZeroBased + | Negate + | OpLeft Name + | OpRight Name + | IfCondition + | IfBranch Index.ZeroBased + | CaseBranch Index.ZeroBased + | CallArity MaybeName Int + | CallArg MaybeName Index.ZeroBased + | RecordAccess A.Region (Maybe Name) A.Region Name + | RecordUpdateKeys (Dict String Name Can.FieldUpdate) + | RecordUpdateValue Name + | Destructure + + +type SubContext + = TypedIfBranch Index.ZeroBased + | TypedCaseBranch Index.ZeroBased + | TypedBody + + +type MaybeName + = FuncName Name + | CtorName Name + | OpName Name + | NoName + + +type Category + = List + | Number + | Float + | String + | Char + | If + | Case + | CallResult MaybeName + | Lambda + | Accessor Name + | Access Name + | Record + | Tuple + | Unit + | Shader + | Effects + | Local Name + | Foreign Name + + + +-- PATTERN EXPECTATIONS + + +type PExpected tipe + = PNoExpectation tipe + | PFromContext A.Region PContext tipe + + +type PContext + = PTypedArg Name Index.ZeroBased + | PCaseMatch Index.ZeroBased + | PCtorArg Name Index.ZeroBased + | PListEntry Index.ZeroBased + | PTail + + +type PCategory + = PRecord + | PUnit + | PTuple + | PList + | PCtor Name + | PInt + | PStr + | PChr + | PBool + + + +-- HELPERS + + +typeReplace : Expected a -> b -> Expected b +typeReplace expectation tipe = + case expectation of + NoExpectation _ -> + NoExpectation tipe + + FromContext region context _ -> + FromContext region context tipe + + FromAnnotation name arity context _ -> + FromAnnotation name arity context tipe + + +ptypeReplace : PExpected a -> b -> PExpected b +ptypeReplace expectation tipe = + case expectation of + PNoExpectation _ -> + PNoExpectation tipe + + PFromContext region context _ -> + PFromContext region context tipe + + + +-- TO REPORT + + +toReport : Code.Source -> L.Localizer -> Error -> Report.Report +toReport source localizer err = + case err of + BadExpr region category actualType expected -> + toExprReport source localizer region category actualType expected + + BadPattern region category tipe expected -> + toPatternReport source localizer region category tipe expected + + InfiniteType region name overallType -> + toInfiniteReport source localizer region name overallType + + + +-- TO PATTERN REPORT + + +toPatternReport : Code.Source -> L.Localizer -> A.Region -> PCategory -> T.Type -> PExpected T.Type -> Report.Report +toPatternReport source localizer patternRegion category tipe expected = + Report.Report "TYPE MISMATCH" patternRegion [] <| + case expected of + PNoExpectation expectedType -> + Code.toSnippet source patternRegion Nothing <| + ( D.fromChars "This pattern is being used in an unexpected way:" + , patternTypeComparison localizer + tipe + expectedType + (addPatternCategory "It is" category) + "But it needs to match:" + [] + ) + + PFromContext region context expectedType -> + Code.toSnippet source region (Just patternRegion) <| + case context of + PTypedArg name index -> + ( D.reflow <| + "The " + ++ D.ordinal index + ++ " argument to `" + ++ name + ++ "` is weird." + , patternTypeComparison localizer + tipe + expectedType + (addPatternCategory "The argument is a pattern that matches" category) + ("But the type annotation on `" + ++ name + ++ "` says the " + ++ D.ordinal index + ++ " argument should be:" + ) + [] + ) + + PCaseMatch index -> + if index == Index.first then + ( D.reflow <| + "The 1st pattern in this `case` causing a mismatch:" + , patternTypeComparison localizer + tipe + expectedType + (addPatternCategory "The first pattern is trying to match" category) + "But the expression between `case` and `of` is:" + [ D.reflow <| + "These can never match! Is the pattern the problem? Or is it the expression?" + ] + ) + + else + ( D.reflow <| + "The " + ++ D.ordinal index + ++ " pattern in this `case` does not match the previous ones." + , patternTypeComparison localizer + tipe + expectedType + (addPatternCategory ("The " ++ D.ordinal index ++ " pattern is trying to match") category) + "But all the previous patterns match:" + [ D.link "Note" + "A `case` expression can only handle one type of value, so you may want to use" + "custom-types" + "to handle “mixing” types." + ] + ) + + PCtorArg name index -> + ( D.reflow <| + "The " + ++ D.ordinal index + ++ " argument to `" + ++ name + ++ "` is weird." + , patternTypeComparison localizer + tipe + expectedType + (addPatternCategory "It is trying to match" category) + ("But `" + ++ name + ++ "` needs its " + ++ D.ordinal index + ++ " argument to be:" + ) + [] + ) + + PListEntry index -> + ( D.reflow <| + "The " + ++ D.ordinal index + ++ " pattern in this list does not match all the previous ones:" + , patternTypeComparison localizer + tipe + expectedType + (addPatternCategory ("The " ++ D.ordinal index ++ " pattern is trying to match") category) + "But all the previous patterns in the list are:" + [ D.link "Hint" + "Everything in a list must be the same type of value. This way, we never run into unexpected values partway through a List.map, List.foldl, etc. Read" + "custom-types" + "to learn how to “mix” types." + ] + ) + + PTail -> + ( D.reflow <| + "The pattern after (::) is causing issues." + , patternTypeComparison localizer + tipe + expectedType + (addPatternCategory "The pattern after (::) is trying to match" category) + "But it needs to match lists like this:" + [] + ) + + + +-- PATTERN HELPERS + + +patternTypeComparison : L.Localizer -> T.Type -> T.Type -> String -> String -> List D.Doc -> D.Doc +patternTypeComparison localizer actual expected iAmSeeing insteadOf contextHints = + let + ( actualDoc, expectedDoc, problems ) = + T.toComparison localizer actual expected + in + D.stack <| + [ D.reflow iAmSeeing + , D.indent 4 actualDoc + , D.reflow insteadOf + , D.indent 4 expectedDoc + ] + ++ problemsToHint problems + ++ contextHints + + +addPatternCategory : String -> PCategory -> String +addPatternCategory iAmTryingToMatch category = + iAmTryingToMatch + ++ (case category of + PRecord -> + " record values of type:" + + PUnit -> + " unit values:" + + PTuple -> + " tuples of type:" + + PList -> + " lists of type:" + + PCtor name -> + " `" ++ name ++ "` values of type:" + + PInt -> + " integers:" + + PStr -> + " strings:" + + PChr -> + " characters:" + + PBool -> + " booleans:" + ) + + + +-- EXPR HELPERS + + +typeComparison : L.Localizer -> T.Type -> T.Type -> String -> String -> List D.Doc -> D.Doc +typeComparison localizer actual expected iAmSeeing insteadOf contextHints = + let + ( actualDoc, expectedDoc, problems ) = + T.toComparison localizer actual expected + in + D.stack <| + [ D.reflow iAmSeeing + , D.indent 4 actualDoc + , D.reflow insteadOf + , D.indent 4 expectedDoc + ] + ++ contextHints + ++ problemsToHint problems + + +loneType : L.Localizer -> T.Type -> T.Type -> D.Doc -> List D.Doc -> D.Doc +loneType localizer actual expected iAmSeeing furtherDetails = + let + ( actualDoc, _, problems ) = + T.toComparison localizer actual expected + in + D.stack <| + [ iAmSeeing + , D.indent 4 actualDoc + ] + ++ furtherDetails + ++ problemsToHint problems + + +addCategory : String -> Category -> String +addCategory thisIs category = + case category of + Local name -> + "This `" ++ name ++ "` value is a:" + + Foreign name -> + "This `" ++ name ++ "` value is a:" + + Access field -> + "The value at ." ++ field ++ " is a:" + + Accessor field -> + "This ." ++ field ++ " field access function has type:" + + If -> + "This `if` expression produces:" + + Case -> + "This `case` expression produces:" + + List -> + thisIs ++ " a list of type:" + + Number -> + thisIs ++ " a number of type:" + + Float -> + thisIs ++ " a float of type:" + + String -> + thisIs ++ " a string of type:" + + Char -> + thisIs ++ " a character of type:" + + Lambda -> + thisIs ++ " an anonymous function of type:" + + Record -> + thisIs ++ " a record of type:" + + Tuple -> + thisIs ++ " a tuple of type:" + + Unit -> + thisIs ++ " a unit value:" + + Shader -> + thisIs ++ " a GLSL shader of type:" + + Effects -> + thisIs ++ " a thing for CORE LIBRARIES ONLY." + + CallResult maybeName -> + case maybeName of + NoName -> + thisIs ++ ":" + + FuncName name -> + "This `" ++ name ++ "` call produces:" + + CtorName name -> + "This `" ++ name ++ "` call produces:" + + OpName _ -> + thisIs ++ ":" + + +problemsToHint : List T.Problem -> List D.Doc +problemsToHint problems = + case problems of + [] -> + [] + + problem :: _ -> + problemToHint problem + + +problemToHint : T.Problem -> List D.Doc +problemToHint problem = + case problem of + T.IntFloat -> + [ D.fancyLink "Note" + [ D.fromChars "Read" ] + "implicit-casts" + [ D.fromChars "to" + , D.fromChars "learn" + , D.fromChars "why" + , D.fromChars "Elm" + , D.fromChars "does" + , D.fromChars "not" + , D.fromChars "implicitly" + , D.fromChars "convert" + , D.fromChars "Ints" + , D.fromChars "to" + , D.fromChars "Floats." + , D.fromChars "Use" + , D.green (D.fromChars "toFloat") + , D.fromChars "and" + , D.green (D.fromChars "round") + , D.fromChars "to" + , D.fromChars "do" + , D.fromChars "explicit" + , D.fromChars "conversions." + ] + ] + + T.StringFromInt -> + [ D.toFancyHint + [ D.fromChars "Want" + , D.fromChars "to" + , D.fromChars "convert" + , D.fromChars "an" + , D.fromChars "Int" + , D.fromChars "into" + , D.fromChars "a" + , D.fromChars "String?" + , D.fromChars "Use" + , D.fromChars "the" + , D.green (D.fromChars "String.fromInt") + , D.fromChars "function!" + ] + ] + + T.StringFromFloat -> + [ D.toFancyHint + [ D.fromChars "Want" + , D.fromChars "to" + , D.fromChars "convert" + , D.fromChars "a" + , D.fromChars "Float" + , D.fromChars "into" + , D.fromChars "a" + , D.fromChars "String?" + , D.fromChars "Use" + , D.fromChars "the" + , D.green (D.fromChars "String.fromFloat") + , D.fromChars "function!" + ] + ] + + T.StringToInt -> + [ D.toFancyHint + [ D.fromChars "Want" + , D.fromChars "to" + , D.fromChars "convert" + , D.fromChars "a" + , D.fromChars "String" + , D.fromChars "into" + , D.fromChars "an" + , D.fromChars "Int?" + , D.fromChars "Use" + , D.fromChars "the" + , D.green (D.fromChars "String.toInt") + , D.fromChars "function!" + ] + ] + + T.StringToFloat -> + [ D.toFancyHint + [ D.fromChars "Want" + , D.fromChars "to" + , D.fromChars "convert" + , D.fromChars "a" + , D.fromChars "String" + , D.fromChars "into" + , D.fromChars "a" + , D.fromChars "Float?" + , D.fromChars "Use" + , D.fromChars "the" + , D.green (D.fromChars "String.toFloat") + , D.fromChars "function!" + ] + ] + + T.AnythingToBool -> + [ D.toSimpleHint <| + "Elm does not have “truthiness” such that ints and strings and lists are automatically converted to booleans. Do that conversion explicitly!" + ] + + T.AnythingFromMaybe -> + [ D.toFancyHint + [ D.fromChars "Use" + , D.green (D.fromChars "Maybe.withDefault") + , D.fromChars "to" + , D.fromChars "handle" + , D.fromChars "possible" + , D.fromChars "errors." + , D.fromChars "Longer" + , D.fromChars "term," + , D.fromChars "it" + , D.fromChars "is" + , D.fromChars "usually" + , D.fromChars "better" + , D.fromChars "to" + , D.fromChars "write" + , D.fromChars "out" + , D.fromChars "the" + , D.fromChars "full" + , D.fromChars "`case`" + , D.fromChars "though!" + ] + ] + + T.ArityMismatch x y -> + [ D.toSimpleHint <| + if x < y then + "It looks like it takes too few arguments. I was expecting " ++ String.fromInt (y - x) ++ " more." + + else + "It looks like it takes too many arguments. I see " ++ String.fromInt (x - y) ++ " extra." + ] + + T.BadFlexSuper direction super tipe -> + case tipe of + T.Lambda _ _ _ -> + badFlexSuper direction super tipe + + T.Infinite -> + [] + + T.Error -> + [] + + T.FlexVar _ -> + [] + + T.FlexSuper s _ -> + badFlexFlexSuper super s + + T.RigidVar y -> + badRigidVar y (toASuperThing super) + + T.RigidSuper s _ -> + badRigidSuper s (toASuperThing super) + + T.Type _ _ _ -> + badFlexSuper direction super tipe + + T.Record _ _ -> + badFlexSuper direction super tipe + + T.Unit -> + badFlexSuper direction super tipe + + T.Tuple _ _ _ -> + badFlexSuper direction super tipe + + T.Alias _ _ _ _ -> + badFlexSuper direction super tipe + + T.BadRigidVar x tipe -> + case tipe of + T.Lambda _ _ _ -> + badRigidVar x "a function" + + T.Infinite -> + [] + + T.Error -> + [] + + T.FlexVar _ -> + [] + + T.FlexSuper s _ -> + badRigidVar x (toASuperThing s) + + T.RigidVar y -> + badDoubleRigid x y + + T.RigidSuper _ y -> + badDoubleRigid x y + + T.Type _ n _ -> + badRigidVar x ("a `" ++ n ++ "` value") + + T.Record _ _ -> + badRigidVar x "a record" + + T.Unit -> + badRigidVar x "a unit value" + + T.Tuple _ _ _ -> + badRigidVar x "a tuple" + + T.Alias _ n _ _ -> + badRigidVar x ("a `" ++ n ++ "` value") + + T.BadRigidSuper super x tipe -> + case tipe of + T.Lambda _ _ _ -> + badRigidSuper super "a function" + + T.Infinite -> + [] + + T.Error -> + [] + + T.FlexVar _ -> + [] + + T.FlexSuper s _ -> + badRigidSuper super (toASuperThing s) + + T.RigidVar y -> + badDoubleRigid x y + + T.RigidSuper _ y -> + badDoubleRigid x y + + T.Type _ n _ -> + badRigidSuper super ("a `" ++ n ++ "` value") + + T.Record _ _ -> + badRigidSuper super "a record" + + T.Unit -> + badRigidSuper super "a unit value" + + T.Tuple _ _ _ -> + badRigidSuper super "a tuple" + + T.Alias _ n _ _ -> + badRigidSuper super ("a `" ++ n ++ "` value") + + T.FieldsMissing fields -> + case List.map (D.green << D.fromName) fields of + [] -> + [] + + [ f1 ] -> + [ D.toFancyHint + [ D.fromChars "Looks" + , D.fromChars "like" + , D.fromChars "the" + , f1 + , D.fromChars "field" + , D.fromChars "is" + , D.fromChars "missing." + ] + ] + + fieldDocs -> + [ D.toFancyHint <| + [ D.fromChars "Looks" + , D.fromChars "like" + , D.fromChars "fields" + ] + ++ D.commaSep (D.fromChars "and") identity fieldDocs + ++ [ D.fromChars "are", D.fromChars "missing." ] + ] + + T.FieldTypo typo possibilities -> + case Suggest.sort typo identity possibilities of + [] -> + [] + + nearest :: _ -> + [ D.toFancyHint <| + [ D.fromChars "Seems" + , D.fromChars "like" + , D.fromChars "a" + , D.fromChars "record" + , D.fromChars "field" + , D.fromChars "typo." + , D.fromChars "Maybe" + , D.dullyellow (D.fromName typo) + , D.fromChars "should" + , D.fromChars "be" + , D.green (D.fromName nearest) |> D.a (D.fromChars "?") + ] + , D.toSimpleHint + "Can more type annotations be added? Type annotations always help me give more specific messages, and I think they could help a lot in this case!" + ] + + + +-- BAD RIGID HINTS + + +badRigidVar : Name -> String -> List D.Doc +badRigidVar name aThing = + [ D.toSimpleHint <| + "Your type annotation uses type variable `" + ++ name + ++ "` which means ANY type of value can flow through, but your code is saying it specifically wants " + ++ aThing + ++ ". Maybe change your type annotation to be more specific? Maybe change the code to be more general?" + , D.reflowLink "Read" "type-annotations" "for more advice!" + ] + + +badDoubleRigid : Name -> Name -> List D.Doc +badDoubleRigid x y = + [ D.toSimpleHint <| + "Your type annotation uses `" + ++ x + ++ "` and `" + ++ y + ++ "` as separate type variables. Your code seems to be saying they are the same though. Maybe they should be the same in your type annotation? Maybe your code uses them in a weird way?" + , D.reflowLink "Read" "type-annotations" "for more advice!" + ] + + +toASuperThing : T.Super -> String +toASuperThing super = + case super of + T.Number -> + "a `number` value" + + T.Comparable -> + "a `comparable` value" + + T.CompAppend -> + "a `compappend` value" + + T.Appendable -> + "an `appendable` value" + + + +-- BAD SUPER HINTS + + +badFlexSuper : T.Direction -> T.Super -> T.Type -> List D.Doc +badFlexSuper direction super tipe = + case super of + T.Comparable -> + case tipe of + T.Record _ _ -> + [ D.link "Hint" + "I do not know how to compare records. I can only compare ints, floats, chars, strings, lists of comparable values, and tuples of comparable values. Check out" + "comparing-records" + "for ideas on how to proceed." + ] + + T.Type _ name _ -> + [ D.toSimpleHint <| + "I do not know how to compare `" + ++ name + ++ "` values. I can only compare ints, floats, chars, strings, lists of comparable values, and tuples of comparable values." + , D.reflowLink + "Check out" + "comparing-custom-types" + "for ideas on how to proceed." + ] + + _ -> + [ D.toSimpleHint <| + "I only know how to compare ints, floats, chars, strings, lists of comparable values, and tuples of comparable values." + ] + + T.Appendable -> + [ D.toSimpleHint "I only know how to append strings and lists." + ] + + T.CompAppend -> + [ D.toSimpleHint "Only strings and lists are both comparable and appendable." + ] + + T.Number -> + case tipe of + T.Type home name _ -> + if T.isString home name then + case direction of + T.Have -> + [ D.toFancyHint + [ D.fromChars "Try" + , D.fromChars "using" + , D.green (D.fromChars "String.fromInt") + , D.fromChars "to" + , D.fromChars "convert" + , D.fromChars "it" + , D.fromChars "to" + , D.fromChars "a" + , D.fromChars "string?" + ] + ] + + T.Need -> + [ D.toFancyHint + [ D.fromChars "Try" + , D.fromChars "using" + , D.green (D.fromChars "String.toInt") + , D.fromChars "to" + , D.fromChars "convert" + , D.fromChars "it" + , D.fromChars "to" + , D.fromChars "an" + , D.fromChars "integer?" + ] + ] + + else + badFlexSuperNumber + + _ -> + badFlexSuperNumber + + +badFlexSuperNumber : List D.Doc +badFlexSuperNumber = + [ D.toFancyHint + [ D.fromChars "Only" + , D.green (D.fromChars "Int") + , D.fromChars "and" + , D.green (D.fromChars "Float") + , D.fromChars "values" + , D.fromChars "work" + , D.fromChars "as" + , D.fromChars "numbers." + ] + ] + + +badRigidSuper : T.Super -> String -> List D.Doc +badRigidSuper super aThing = + let + ( superType, manyThings ) = + case super of + T.Number -> + ( "number", "ints AND floats" ) + + T.Comparable -> + ( "comparable", "ints, floats, chars, strings, lists, and tuples" ) + + T.Appendable -> + ( "appendable", "strings AND lists" ) + + T.CompAppend -> + ( "compappend", "strings AND lists" ) + in + [ D.toSimpleHint <| + "The `" + ++ superType + ++ "` in your type annotation is saying that " + ++ manyThings + ++ " can flow through, but your code is saying it specifically wants " + ++ aThing + ++ ". Maybe change your type annotation to be more specific? Maybe change the code to be more general?" + , D.reflowLink "Read" "type-annotations" "for more advice!" + ] + + +badFlexFlexSuper : T.Super -> T.Super -> List D.Doc +badFlexFlexSuper s1 s2 = + let + likeThis : T.Super -> String + likeThis super = + case super of + T.Number -> + "a number" + + T.Comparable -> + "comparable" + + T.CompAppend -> + "a compappend" + + T.Appendable -> + "appendable" + in + [ D.toSimpleHint <| + "There are no values in Elm that are both " + ++ likeThis s1 + ++ " and " + ++ likeThis s2 + ++ "." + ] + + + +-- TO EXPR REPORT + + +toExprReport : Code.Source -> L.Localizer -> A.Region -> Category -> T.Type -> Expected T.Type -> Report.Report +toExprReport source localizer exprRegion category tipe expected = + case expected of + NoExpectation expectedType -> + Report.Report "TYPE MISMATCH" exprRegion [] <| + Code.toSnippet source + exprRegion + Nothing + ( D.fromChars "This expression is being used in an unexpected way:" + , typeComparison localizer + tipe + expectedType + (addCategory "It is" category) + "But you are trying to use it as:" + [] + ) + + FromAnnotation name _ subContext expectedType -> + let + thing : String + thing = + case subContext of + TypedIfBranch index -> + D.ordinal index ++ " branch of this `if` expression:" + + TypedCaseBranch index -> + D.ordinal index ++ " branch of this `case` expression:" + + TypedBody -> + "body of the `" ++ name ++ "` definition:" + + itIs : String + itIs = + case subContext of + TypedIfBranch index -> + "The " ++ D.ordinal index ++ " branch is" + + TypedCaseBranch index -> + "The " ++ D.ordinal index ++ " branch is" + + TypedBody -> + "The body is" + in + Report.Report "TYPE MISMATCH" exprRegion [] <| + Code.toSnippet source exprRegion Nothing <| + ( D.reflow ("Something is off with the " ++ thing) + , typeComparison localizer + tipe + expectedType + (addCategory itIs category) + ("But the type annotation on `" ++ name ++ "` says it should be:") + [] + ) + + FromContext region context expectedType -> + let + mismatch : ( ( Maybe A.Region, String ), ( String, String, List D.Doc ) ) -> Report.Report + mismatch ( ( maybeHighlight, problem ), ( thisIs, insteadOf, furtherDetails ) ) = + Report.Report "TYPE MISMATCH" exprRegion [] <| + Code.toSnippet source + region + maybeHighlight + ( D.reflow problem + , typeComparison localizer tipe expectedType (addCategory thisIs category) insteadOf furtherDetails + ) + + badType : ( ( Maybe A.Region, String ), ( String, List D.Doc ) ) -> Report.Report + badType ( ( maybeHighlight, problem ), ( thisIs, furtherDetails ) ) = + Report.Report "TYPE MISMATCH" exprRegion [] <| + Code.toSnippet source + region + maybeHighlight + ( D.reflow problem + , loneType localizer tipe expectedType (D.reflow (addCategory thisIs category)) furtherDetails + ) + + custom : Maybe A.Region -> ( D.Doc, D.Doc ) -> Report.Report + custom maybeHighlight docPair = + Report.Report "TYPE MISMATCH" exprRegion [] <| + Code.toSnippet source region maybeHighlight docPair + in + case context of + ListEntry index -> + let + ith : String + ith = + D.ordinal index + in + mismatch + ( ( Just exprRegion + , "The " ++ ith ++ " element of this list does not match all the previous elements:" + ) + , ( "The " ++ ith ++ " element is" + , "But all the previous elements in the list are:" + , [ D.link "Hint" + "Everything in a list must be the same type of value. This way, we never run into unexpected values partway through a List.map, List.foldl, etc. Read" + "custom-types" + "to learn how to “mix” types." + ] + ) + ) + + Negate -> + badType + ( ( Just exprRegion + , "I do not know how to negate this type of value:" + ) + , ( "It is" + , [ D.fillSep + [ D.fromChars "But" + , D.fromChars "I" + , D.fromChars "only" + , D.fromChars "now" + , D.fromChars "how" + , D.fromChars "to" + , D.fromChars "negate" + , D.dullyellow (D.fromChars "Int") + , D.fromChars "and" + , D.dullyellow (D.fromChars "Float") + , D.fromChars "values." + ] + ] + ) + ) + + OpLeft op -> + custom (Just exprRegion) <| + opLeftToDocs localizer category op tipe expectedType + + OpRight op -> + case opRightToDocs localizer category op tipe expectedType of + EmphBoth details -> + custom Nothing details + + EmphRight details -> + custom (Just exprRegion) details + + IfCondition -> + badType + ( ( Just exprRegion + , "This `if` condition does not evaluate to a boolean value, True or False." + ) + , ( "It is" + , [ D.fillSep + [ D.fromChars "But" + , D.fromChars "I" + , D.fromChars "need" + , D.fromChars "this" + , D.fromChars "`if`" + , D.fromChars "condition" + , D.fromChars "to" + , D.fromChars "be" + , D.fromChars "a" + , D.dullyellow (D.fromChars "Bool") + , D.fromChars "value." + ] + ] + ) + ) + + IfBranch index -> + let + ith : String + ith = + D.ordinal index + in + mismatch + ( ( Just exprRegion + , "The " ++ ith ++ " branch of this `if` does not match all the previous branches:" + ) + , ( "The " ++ ith ++ " branch is" + , "But all the previous branches result in:" + , [ D.link "Hint" + "All branches in an `if` must produce the same type of values. This way, no matter which branch we take, the result is always a consistent shape. Read" + "custom-types" + "to learn how to “mix” types." + ] + ) + ) + + CaseBranch index -> + let + ith : String + ith = + D.ordinal index + in + mismatch + ( ( Just exprRegion + , "The " ++ ith ++ " branch of this `case` does not match all the previous branches:" + ) + , ( "The " ++ ith ++ " branch is" + , "But all the previous branches result in:" + , [ D.link "Hint" + "All branches in a `case` must produce the same type of values. This way, no matter which branch we take, the result is always a consistent shape. Read" + "custom-types" + "to learn how to “mix” types." + ] + ) + ) + + CallArity maybeFuncName numGivenArgs -> + Report.Report "TOO MANY ARGS" exprRegion [] <| + Code.toSnippet source region (Just exprRegion) <| + case countArgs tipe of + 0 -> + let + thisValue : String + thisValue = + case maybeFuncName of + NoName -> + "This value" + + FuncName name -> + "The `" ++ name ++ "` value" + + CtorName name -> + "The `" ++ name ++ "` value" + + OpName op -> + "The (" ++ op ++ ") operator" + in + ( D.reflow <| thisValue ++ " is not a function, but it was given " ++ D.args numGivenArgs ++ "." + , D.reflow <| "Are there any missing commas? Or missing parentheses?" + ) + + n -> + let + thisFunction : String + thisFunction = + case maybeFuncName of + NoName -> + "This function" + + FuncName name -> + "The `" ++ name ++ "` function" + + CtorName name -> + "The `" ++ name ++ "` constructor" + + OpName op -> + "The (" ++ op ++ ") operator" + in + ( D.reflow <| thisFunction ++ " expects " ++ D.args n ++ ", but it got " ++ String.fromInt numGivenArgs ++ " instead." + , D.reflow <| "Are there any missing commas? Or missing parentheses?" + ) + + CallArg maybeFuncName index -> + let + ith : String + ith = + D.ordinal index + + thisFunction : String + thisFunction = + case maybeFuncName of + NoName -> + "this function" + + FuncName name -> + "`" ++ name ++ "`" + + CtorName name -> + "`" ++ name ++ "`" + + OpName op -> + "(" ++ op ++ ")" + in + mismatch + ( ( Just exprRegion + , "The " ++ ith ++ " argument to " ++ thisFunction ++ " is not what I expect:" + ) + , ( "This argument is" + , "But " ++ thisFunction ++ " needs the " ++ ith ++ " argument to be:" + , if Index.toHuman index == 1 then + [] + + else + [ D.toSimpleHint <| + "I always figure out the argument types from left to right. If an argument is acceptable, I assume it is “correct” and move on. So the problem may actually be in one of the previous arguments!" + ] + ) + ) + + RecordAccess recordRegion maybeName fieldRegion field -> + case T.iteratedDealias tipe of + T.Record fields ext -> + custom (Just fieldRegion) + ( D.reflow <| + "This " + ++ Maybe.withDefault "" (Maybe.map (\n -> "`" ++ n ++ "`") maybeName) + ++ " record does not have a `" + ++ field + ++ "` field:" + , case Suggest.sort field Tuple.first (Dict.toList compare fields) of + [] -> + D.reflow "In fact, it is a record with NO fields!" + + f :: fs -> + D.stack + [ D.reflow <| + "This is usually a typo. Here are the " + ++ Maybe.withDefault "" (Maybe.map (\n -> "`" ++ n ++ "`") maybeName) + ++ " fields that are most similar:" + , toNearbyRecord localizer f fs ext + , D.fillSep + [ D.fromChars "So" + , D.fromChars "maybe" + , D.dullyellow (D.fromName field) + , D.fromChars "should" + , D.fromChars "be" + , D.green (D.fromName (Tuple.first f)) + |> D.a (D.fromChars "?") + ] + ] + ) + + _ -> + badType + ( ( Just recordRegion + , "This is not a record, so it has no fields to access!" + ) + , ( "It is" + , [ D.fillSep + [ D.fromChars "But" + , D.fromChars "I" + , D.fromChars "need" + , D.fromChars "a" + , D.fromChars "record" + , D.fromChars "with" + , D.fromChars "a" + , D.dullyellow (D.fromName field) + , D.fromChars "field!" + ] + ] + ) + ) + + RecordUpdateKeys expectedFields -> + case T.iteratedDealias tipe of + T.Record actualFields ext -> + case List.sortBy Tuple.first (Dict.toList compare (Dict.diff expectedFields actualFields)) of + [] -> + mismatch + ( ( Nothing + , "Something is off with this record update:" + ) + , ( "The record is" + , "But this update needs it to be compatable with:" + , [ D.reflow + "Do you mind creating an that produces this error message and sharing it at so we can try to give better advice here?" + ] + ) + ) + + ( field, Can.FieldUpdate fieldRegion _ ) :: _ -> + let + fStr : String + fStr = + "`" ++ field ++ "`" + in + custom (Just fieldRegion) + ( D.reflow <| + "The record does not have a " + ++ fStr + ++ " field:" + , case Suggest.sort field Tuple.first (Dict.toList compare actualFields) of + [] -> + D.reflow <| "In fact, it is a record with NO fields!" + + f :: fs -> + D.stack + [ D.reflow <| + "This is usually a typo. Here are the record fields that are most similar:" + , toNearbyRecord localizer f fs ext + , D.fillSep + [ D.fromChars "So" + , D.fromChars "maybe" + , D.dullyellow (D.fromName field) + , D.fromChars "should" + , D.fromChars "be" + , D.green (D.fromName (Tuple.first f)) + |> D.a (D.fromChars "?") + ] + ] + ) + + _ -> + badType + ( ( Just exprRegion + , "This is not a record, so it has no fields to update!" + ) + , ( "It is" + , [ D.reflow <| "But I need a record!" + ] + ) + ) + + RecordUpdateValue field -> + mismatch + ( ( Just exprRegion + , "I cannot update the `" ++ field ++ "` field like this:" + ) + , ( "You are trying to update `" ++ field ++ "` to be" + , "But it should be:" + , [ D.toSimpleNote + "The record update syntax does not allow you to change the type of fields. You can achieve that with record constructors or the record literal syntax." + ] + ) + ) + + Destructure -> + mismatch + ( ( Nothing + , "This definition is causing issues:" + ) + , ( "You are defining" + , "But then trying to destructure it as:" + , [] + ) + ) + + + +-- HELPERS + + +countArgs : T.Type -> Int +countArgs tipe = + case tipe of + T.Lambda _ _ stuff -> + 1 + List.length stuff + + _ -> + 0 + + + +-- FIELD NAME HELPERS + + +toNearbyRecord : L.Localizer -> ( Name, T.Type ) -> List ( Name, T.Type ) -> T.Extension -> D.Doc +toNearbyRecord localizer f fs ext = + D.indent 4 <| + if List.length fs <= 3 then + RT.vrecord (List.map (fieldToDocs localizer) (f :: fs)) (extToDoc ext) + + else + RT.vrecordSnippet (fieldToDocs localizer f) (List.map (fieldToDocs localizer) (List.take 3 fs)) + + +fieldToDocs : L.Localizer -> ( Name, T.Type ) -> ( D.Doc, D.Doc ) +fieldToDocs localizer ( name, tipe ) = + ( D.fromName name + , T.toDoc localizer RT.None tipe + ) + + +extToDoc : T.Extension -> Maybe D.Doc +extToDoc ext = + case ext of + T.Closed -> + Nothing + + T.FlexOpen x -> + Just (D.fromName x) + + T.RigidOpen x -> + Just (D.fromName x) + + + +-- OP LEFT + + +opLeftToDocs : L.Localizer -> Category -> Name -> T.Type -> T.Type -> ( D.Doc, D.Doc ) +opLeftToDocs localizer category op tipe expected = + case op of + "+" -> + if isString tipe then + badStringAdd + + else if isList tipe then + badListAdd localizer category "left" tipe expected + + else + badMath localizer category "Addition" "left" "+" tipe expected [] + + "*" -> + if isList tipe then + badListMul localizer category "left" tipe expected + + else + badMath localizer category "Multiplication" "left" "*" tipe expected [] + + "-" -> + badMath localizer category "Subtraction" "left" "-" tipe expected [] + + "^" -> + badMath localizer category "Exponentiation" "left" "^" tipe expected [] + + "/" -> + badFDiv localizer (D.fromChars "left") tipe expected + + "//" -> + badIDiv localizer (D.fromChars "left") tipe expected + + "&&" -> + badBool localizer (D.fromChars "&&") (D.fromChars "left") tipe expected + + "||" -> + badBool localizer (D.fromChars "||") (D.fromChars "left") tipe expected + + "<" -> + badCompLeft localizer category "<" "left" tipe expected + + ">" -> + badCompLeft localizer category ">" "left" tipe expected + + "<=" -> + badCompLeft localizer category "<=" "left" tipe expected + + ">=" -> + badCompLeft localizer category ">=" "left" tipe expected + + "++" -> + badAppendLeft localizer category tipe expected + + "<|" -> + ( D.fromChars "The left side of (<|) needs to be a function so I can pipe arguments to it!" + , loneType localizer + tipe + expected + (D.reflow (addCategory "I am seeing" category)) + [ D.reflow "This needs to be some kind of function though!" ] + ) + + _ -> + ( D.reflow ("The left argument of (" ++ op ++ ") is causing problems:") + , typeComparison localizer + tipe + expected + (addCategory "The left argument is" category) + ("But (" ++ op ++ ") needs the left argument to be:") + [] + ) + + + +-- OP RIGHT + + +type RightDocs + = EmphBoth ( D.Doc, D.Doc ) + | EmphRight ( D.Doc, D.Doc ) + + +opRightToDocs : L.Localizer -> Category -> Name -> T.Type -> T.Type -> RightDocs +opRightToDocs localizer category op tipe expected = + case op of + "+" -> + if isFloat expected && isInt tipe then + badCast op FloatInt + + else if isInt expected && isFloat tipe then + badCast op IntFloat + + else if isString tipe then + EmphRight badStringAdd + + else if isList tipe then + EmphRight (badListAdd localizer category "right" tipe expected) + + else + EmphRight (badMath localizer category "Addition" "right" "+" tipe expected []) + + "*" -> + if isFloat expected && isInt tipe then + badCast op FloatInt + + else if isInt expected && isFloat tipe then + badCast op IntFloat + + else if isList tipe then + EmphRight (badListMul localizer category "right" tipe expected) + + else + EmphRight (badMath localizer category "Multiplication" "right" "*" tipe expected []) + + "-" -> + if isFloat expected && isInt tipe then + badCast op FloatInt + + else if isInt expected && isFloat tipe then + badCast op IntFloat + + else + EmphRight (badMath localizer category "Subtraction" "right" "-" tipe expected []) + + "^" -> + if isFloat expected && isInt tipe then + badCast op FloatInt + + else if isInt expected && isFloat tipe then + badCast op IntFloat + + else + EmphRight (badMath localizer category "Exponentiation" "right" "^" tipe expected []) + + "/" -> + EmphRight (badFDiv localizer (D.fromChars "right") tipe expected) + + "//" -> + EmphRight (badIDiv localizer (D.fromChars "right") tipe expected) + + "&&" -> + EmphRight (badBool localizer (D.fromChars "&&") (D.fromChars "right") tipe expected) + + "||" -> + EmphRight (badBool localizer (D.fromChars "||") (D.fromChars "right") tipe expected) + + "<" -> + badCompRight localizer "<" tipe expected + + ">" -> + badCompRight localizer ">" tipe expected + + "<=" -> + badCompRight localizer "<=" tipe expected + + ">=" -> + badCompRight localizer ">=" tipe expected + + "==" -> + badEquality localizer "==" tipe expected + + "/=" -> + badEquality localizer "/=" tipe expected + + "::" -> + badConsRight localizer category tipe expected + + "++" -> + badAppendRight localizer category tipe expected + + "<|" -> + EmphRight + ( D.reflow "I cannot send this through the (<|) pipe:" + , typeComparison localizer + tipe + expected + "The argument is:" + "But (<|) is piping it to a function that expects:" + [] + ) + + "|>" -> + case ( tipe, expected ) of + ( T.Lambda expectedArgType _ _, T.Lambda argType _ _ ) -> + EmphRight + ( D.reflow "This function cannot handle the argument sent through the (|>) pipe:" + , typeComparison localizer + argType + expectedArgType + "The argument is:" + "But (|>) is piping it to a function that expects:" + [] + ) + + _ -> + EmphRight + ( D.reflow "The right side of (|>) needs to be a function so I can pipe arguments to it!" + , loneType localizer + tipe + expected + (D.reflow (addCategory "But instead of a function, I am seeing" category)) + [] + ) + + _ -> + badOpRightFallback localizer category op tipe expected + + +badOpRightFallback : L.Localizer -> Category -> Name -> T.Type -> T.Type -> RightDocs +badOpRightFallback localizer category op tipe expected = + EmphRight + ( D.reflow ("The right argument of (" ++ op ++ ") is causing problems.") + , typeComparison localizer + tipe + expected + (addCategory "The right argument is" category) + ("But (" ++ op ++ ") needs the right argument to be:") + [ D.toSimpleHint <| + "With operators like (" + ++ op + ++ ") I always check the left side first. If it seems fine, I assume it is correct and check the right side. So the problem may be in how the left and right arguments interact!" + ] + ) + + +isInt : T.Type -> Bool +isInt tipe = + case tipe of + T.Type home name [] -> + T.isInt home name + + _ -> + False + + +isFloat : T.Type -> Bool +isFloat tipe = + case tipe of + T.Type home name [] -> + T.isFloat home name + + _ -> + False + + +isString : T.Type -> Bool +isString tipe = + case tipe of + T.Type home name [] -> + T.isString home name + + _ -> + False + + +isList : T.Type -> Bool +isList tipe = + case tipe of + T.Type home name [ _ ] -> + T.isList home name + + _ -> + False + + + +-- BAD CONS + + +badConsRight : L.Localizer -> Category -> T.Type -> T.Type -> RightDocs +badConsRight localizer category tipe expected = + case tipe of + T.Type home1 name1 [ actualElement ] -> + if T.isList home1 name1 then + case expected of + T.Type home2 name2 [ expectedElement ] -> + if T.isList home2 name2 then + EmphBoth + ( D.reflow "I am having trouble with this (::) operator:" + , typeComparison localizer + expectedElement + actualElement + "The left side of (::) is:" + "But you are trying to put that into a list filled with:" + (case expectedElement of + T.Type home name [ _ ] -> + if T.isList home name then + [ D.toSimpleHint + "Are you trying to append two lists? The (++) operator appends lists, whereas the (::) operator is only for adding ONE element to a list." + ] + + else + [ D.reflow + "Lists need ALL elements to be the same type though." + ] + + _ -> + [ D.reflow + "Lists need ALL elements to be the same type though." + ] + ) + ) + + else + badOpRightFallback localizer category "::" tipe expected + + _ -> + badOpRightFallback localizer category "::" tipe expected + + else + EmphRight + ( D.reflow "The (::) operator can only add elements onto lists." + , loneType localizer + tipe + expected + (D.reflow (addCategory "The right side is" category)) + [ D.fillSep + [ D.fromChars "But" + , D.fromChars "(::)" + , D.fromChars "needs" + , D.fromChars "a" + , D.dullyellow (D.fromChars "List") + , D.fromChars "on" + , D.fromChars "the" + , D.fromChars "right." + ] + ] + ) + + _ -> + EmphRight + ( D.reflow "The (::) operator can only add elements onto lists." + , loneType localizer + tipe + expected + (D.reflow (addCategory "The right side is" category)) + [ D.fillSep + [ D.fromChars "But" + , D.fromChars "(::)" + , D.fromChars "needs" + , D.fromChars "a" + , D.dullyellow (D.fromChars "List") + , D.fromChars "on" + , D.fromChars "the" + , D.fromChars "right." + ] + ] + ) + + + +-- BAD APPEND + + +type AppendType + = ANumber D.Doc D.Doc + | AString + | AList + | AOther + + +toAppendType : T.Type -> AppendType +toAppendType tipe = + case tipe of + T.Type home name _ -> + if T.isInt home name then + ANumber (D.fromChars "Int") (D.fromChars "String.fromInt") + + else if T.isFloat home name then + ANumber (D.fromChars "Float") (D.fromChars "String.fromFloat") + + else if T.isString home name then + AString + + else if T.isList home name then + AList + + else + AOther + + T.FlexSuper T.Number _ -> + ANumber (D.fromChars "number") (D.fromChars "String.fromInt") + + _ -> + AOther + + +badAppendLeft : L.Localizer -> Category -> T.Type -> T.Type -> ( D.Doc, D.Doc ) +badAppendLeft localizer category tipe expected = + case toAppendType tipe of + ANumber thing stringFromThing -> + ( D.fillSep + [ D.fromChars "The" + , D.fromChars "(++)" + , D.fromChars "operator" + , D.fromChars "can" + , D.fromChars "append" + , D.fromChars "List" + , D.fromChars "and" + , D.fromChars "String" + , D.fromChars "values," + , D.fromChars "but" + , D.fromChars "not" + , D.dullyellow thing + , D.fromChars "values" + , D.fromChars "like" + , D.fromChars "this:" + ] + , D.fillSep + [ D.fromChars "Try" + , D.fromChars "using" + , D.green stringFromThing + , D.fromChars "to" + , D.fromChars "turn" + , D.fromChars "it" + , D.fromChars "into" + , D.fromChars "a" + , D.fromChars "string?" + , D.fromChars "Or" + , D.fromChars "put" + , D.fromChars "it" + , D.fromChars "in" + , D.fromChars "[]" + , D.fromChars "to" + , D.fromChars "make" + , D.fromChars "it" + , D.fromChars "a" + , D.fromChars "list?" + , D.fromChars "Or" + , D.fromChars "switch" + , D.fromChars "to" + , D.fromChars "the" + , D.fromChars "(::)" + , D.fromChars "operator?" + ] + ) + + _ -> + ( D.reflow "The (++) operator cannot append this type of value:" + , loneType localizer + tipe + expected + (D.reflow (addCategory "I am seeing" category)) + [ D.fillSep + [ D.fromChars "But" + , D.fromChars "the" + , D.fromChars "(++)" + , D.fromChars "operator" + , D.fromChars "is" + , D.fromChars "only" + , D.fromChars "for" + , D.fromChars "appending" + , D.dullyellow (D.fromChars "List") + , D.fromChars "and" + , D.dullyellow (D.fromChars "String") + , D.fromChars "values." + , D.fromChars "Maybe" + , D.fromChars "put" + , D.fromChars "this" + , D.fromChars "value" + , D.fromChars "in" + , D.fromChars "[]" + , D.fromChars "to" + , D.fromChars "make" + , D.fromChars "it" + , D.fromChars "a" + , D.fromChars "list?" + ] + ] + ) + + +badAppendRight : L.Localizer -> Category -> T.Type -> T.Type -> RightDocs +badAppendRight localizer category tipe expected = + case ( toAppendType expected, toAppendType tipe ) of + ( AString, ANumber thing stringFromThing ) -> + EmphRight + ( D.fillSep + [ D.fromChars "I" + , D.fromChars "thought" + , D.fromChars "I" + , D.fromChars "was" + , D.fromChars "appending" + , D.dullyellow (D.fromChars "String") + , D.fromChars "values" + , D.fromChars "here," + , D.fromChars "not" + , D.dullyellow thing + , D.fromChars "values" + , D.fromChars "like" + , D.fromChars "this:" + ] + , D.fillSep + [ D.fromChars "Try" + , D.fromChars "using" + , D.green stringFromThing + , D.fromChars "to" + , D.fromChars "turn" + , D.fromChars "it" + , D.fromChars "into" + , D.fromChars "a" + , D.fromChars "string?" + ] + ) + + ( AList, ANumber thing _ ) -> + EmphRight + ( D.fillSep + [ D.fromChars "I" + , D.fromChars "thought" + , D.fromChars "I" + , D.fromChars "was" + , D.fromChars "appending" + , D.dullyellow (D.fromChars "List") + , D.fromChars "values" + , D.fromChars "here," + , D.fromChars "not" + , D.dullyellow thing + , D.fromChars "values" + , D.fromChars "like" + , D.fromChars "this:" + ] + , D.reflow "Try putting it in [] to make it a list?" + ) + + ( AString, AList ) -> + EmphBoth + ( D.reflow "The (++) operator needs the same type of value on both sides:" + , D.fillSep + [ D.fromChars "I" + , D.fromChars "see" + , D.fromChars "a" + , D.dullyellow (D.fromChars "String") + , D.fromChars "on" + , D.fromChars "the" + , D.fromChars "left" + , D.fromChars "and" + , D.fromChars "a" + , D.dullyellow (D.fromChars "List") + , D.fromChars "on" + , D.fromChars "the" + , D.fromChars "right." + , D.fromChars "Which" + , D.fromChars "should" + , D.fromChars "it" + , D.fromChars "be?" + , D.fromChars "Does" + , D.fromChars "the" + , D.fromChars "string" + , D.fromChars "need" + , D.fromChars "[]" + , D.fromChars "around" + , D.fromChars "it" + , D.fromChars "to" + , D.fromChars "become" + , D.fromChars "a" + , D.fromChars "list?" + ] + ) + + ( AList, AString ) -> + EmphBoth + ( D.reflow "The (++) operator needs the same type of value on both sides:" + , D.fillSep + [ D.fromChars "I" + , D.fromChars "see" + , D.fromChars "a" + , D.dullyellow (D.fromChars "List") + , D.fromChars "on" + , D.fromChars "the" + , D.fromChars "left" + , D.fromChars "and" + , D.fromChars "a" + , D.dullyellow (D.fromChars "String") + , D.fromChars "on" + , D.fromChars "the" + , D.fromChars "right." + , D.fromChars "Which" + , D.fromChars "should" + , D.fromChars "it" + , D.fromChars "be?" + , D.fromChars "Does" + , D.fromChars "the" + , D.fromChars "string" + , D.fromChars "need" + , D.fromChars "[]" + , D.fromChars "around" + , D.fromChars "it" + , D.fromChars "to" + , D.fromChars "become" + , D.fromChars "a" + , D.fromChars "list?" + ] + ) + + _ -> + EmphBoth + ( D.reflow "The (++) operator cannot append these two values:" + , typeComparison localizer + expected + tipe + "I already figured out that the left side of (++) is:" + (addCategory "But this clashes with the right side, which is" category) + [] + ) + + + +-- BAD MATH + + +type ThisThenThat + = FloatInt + | IntFloat + + +badCast : Name -> ThisThenThat -> RightDocs +badCast op thisThenThat = + EmphBoth + ( D.reflow <| + "I need both sides of (" + ++ op + ++ ") to be the exact same type. Both Int or both Float." + , let + anInt : List D.Doc + anInt = + [ D.fromChars "an", D.dullyellow (D.fromChars "Int") ] + + aFloat : List D.Doc + aFloat = + [ D.fromChars "a", D.dullyellow (D.fromChars "Float") ] + + toFloat : D.Doc + toFloat = + D.green (D.fromChars "toFloat") + + round : D.Doc + round = + D.green (D.fromChars "round") + in + case thisThenThat of + FloatInt -> + badCastHelp aFloat anInt round toFloat + + IntFloat -> + badCastHelp anInt aFloat toFloat round + ) + + +badCastHelp : List D.Doc -> List D.Doc -> D.Doc -> D.Doc -> D.Doc +badCastHelp anInt aFloat toFloat round = + D.stack + [ D.fillSep <| + [ D.fromChars "But" + , D.fromChars "I" + , D.fromChars "see" + ] + ++ anInt + ++ [ D.fromChars "on" + , D.fromChars "the" + , D.fromChars "left" + , D.fromChars "and" + ] + ++ aFloat + ++ [ D.fromChars "on" + , D.fromChars "the" + , D.fromChars "right." + ] + , D.fillSep + [ D.fromChars "Use" + , toFloat + , D.fromChars "on" + , D.fromChars "the" + , D.fromChars "left" + , D.fromChars "(or" + , round + , D.fromChars "on" + , D.fromChars "the" + , D.fromChars "right)" + , D.fromChars "to" + , D.fromChars "make" + , D.fromChars "both" + , D.fromChars "sides" + , D.fromChars "match!" + ] + , D.link "Note" "Read" "implicit-casts" "to learn why Elm does not implicitly convert Ints to Floats." + ] + + +badStringAdd : ( D.Doc, D.Doc ) +badStringAdd = + ( D.fillSep + [ D.fromChars "I" + , D.fromChars "cannot" + , D.fromChars "do" + , D.fromChars "addition" + , D.fromChars "with" + , D.dullyellow (D.fromChars "String") + , D.fromChars "values" + , D.fromChars "like" + , D.fromChars "this" + , D.fromChars "one:" + ] + , D.stack + [ D.fillSep + [ D.fromChars "The" + , D.fromChars "(+)" + , D.fromChars "operator" + , D.fromChars "only" + , D.fromChars "works" + , D.fromChars "with" + , D.dullyellow (D.fromChars "Int") + , D.fromChars "and" + , D.dullyellow (D.fromChars "Float") + , D.fromChars "values." + ] + , D.toFancyHint + [ D.fromChars "Switch" + , D.fromChars "to" + , D.fromChars "the" + , D.green (D.fromChars "(++)") + , D.fromChars "operator" + , D.fromChars "to" + , D.fromChars "append" + , D.fromChars "strings!" + ] + ] + ) + + +badListAdd : L.Localizer -> Category -> String -> T.Type -> T.Type -> ( D.Doc, D.Doc ) +badListAdd localizer category direction tipe expected = + ( D.fromChars "I cannot do addition with lists:" + , loneType localizer + tipe + expected + (D.reflow (addCategory ("The " ++ direction ++ " side of (+) is") category)) + [ D.fillSep + [ D.fromChars "But" + , D.fromChars "(+)" + , D.fromChars "only" + , D.fromChars "works" + , D.fromChars "with" + , D.dullyellow (D.fromChars "Int") + , D.fromChars "and" + , D.dullyellow (D.fromChars "Float") + , D.fromChars "values." + ] + , D.toFancyHint + [ D.fromChars "Switch" + , D.fromChars "to" + , D.fromChars "the" + , D.green (D.fromChars "(++)") + , D.fromChars "operator" + , D.fromChars "to" + , D.fromChars "append" + , D.fromChars "lists!" + ] + ] + ) + + +badListMul : L.Localizer -> Category -> String -> T.Type -> T.Type -> ( D.Doc, D.Doc ) +badListMul localizer category direction tipe expected = + badMath localizer category "Multiplication" direction "*" tipe expected <| + [ D.toFancyHint + [ D.fromChars "Maybe" + , D.fromChars "you" + , D.fromChars "want" + , D.green (D.fromChars "List.repeat") + , D.fromChars "to" + , D.fromChars "build" + , D.fromChars "a" + , D.fromChars "list" + , D.fromChars "of" + , D.fromChars "repeated" + , D.fromChars "values?" + ] + ] + + +badMath : L.Localizer -> Category -> String -> String -> String -> T.Type -> T.Type -> List D.Doc -> ( D.Doc, D.Doc ) +badMath localizer category operation direction op tipe expected otherHints = + ( D.reflow <| + operation + ++ " does not work with this value:" + , loneType localizer + tipe + expected + (D.reflow (addCategory ("The " ++ direction ++ " side of (" ++ op ++ ") is") category)) + (D.fillSep + [ D.fromChars "But" + , D.fromChars ("(" ++ op ++ ")") + , D.fromChars "only" + , D.fromChars "works" + , D.fromChars "with" + , D.dullyellow (D.fromChars "Int") + , D.fromChars "and" + , D.dullyellow (D.fromChars "Float") + , D.fromChars "values." + ] + :: otherHints + ) + ) + + +badFDiv : L.Localizer -> D.Doc -> T.Type -> T.Type -> ( D.Doc, D.Doc ) +badFDiv localizer direction tipe expected = + ( D.reflow "The (/) operator is specifically for floating-point division:" + , if isInt tipe then + D.stack + [ D.fillSep + [ D.fromChars "The" + , direction + , D.fromChars "side" + , D.fromChars "of" + , D.fromChars "(/)" + , D.fromChars "must" + , D.fromChars "be" + , D.fromChars "a" + , D.dullyellow (D.fromChars "Float") |> D.a (D.fromChars ",") + , D.fromChars "but" + , D.fromChars "I" + , D.fromChars "am" + , D.fromChars "seeing" + , D.fromChars "an" + , D.dullyellow (D.fromChars "Int") |> D.a (D.fromChars ".") + , D.fromChars "I" + , D.fromChars "recommend:" + ] + , D.vcat + [ D.green (D.fromChars "toFloat") + |> D.a (D.fromChars " for explicit conversions ") + |> D.a (D.black (D.fromChars "(toFloat 5 / 2) == 2.5")) + , D.green (D.fromChars "(//) ") + |> D.a (D.fromChars " for integer division ") + |> D.a (D.black (D.fromChars "(5 // 2) == 2")) + ] + , D.link "Note" "Read" "implicit-casts" "to learn why Elm does not implicitly convert Ints to Floats." + ] + + else + loneType localizer + tipe + expected + (D.fillSep + [ D.fromChars "The" + , direction + , D.fromChars "side" + , D.fromChars "of" + , D.fromChars "(/)" + , D.fromChars "must" + , D.fromChars "be" + , D.fromChars "a" + , D.dullyellow (D.fromChars "Float") |> D.a (D.fromChars ",") + , D.fromChars "but" + , D.fromChars "instead" + , D.fromChars "I" + , D.fromChars "am" + , D.fromChars "seeing:" + ] + ) + [] + ) + + +badIDiv : L.Localizer -> D.Doc -> T.Type -> T.Type -> ( D.Doc, D.Doc ) +badIDiv localizer direction tipe expected = + ( D.reflow "The (//) operator is specifically for integer division:" + , if isFloat tipe then + D.stack + [ D.fillSep + [ D.fromChars "The" + , direction + , D.fromChars "side" + , D.fromChars "of" + , D.fromChars "(//)" + , D.fromChars "must" + , D.fromChars "be" + , D.fromChars "an" + , D.dullyellow (D.fromChars "Int") |> D.a (D.fromChars ",") + , D.fromChars "but" + , D.fromChars "I" + , D.fromChars "am" + , D.fromChars "seeing" + , D.fromChars "a" + , D.dullyellow (D.fromChars "Float") |> D.a (D.fromChars ".") + , D.fromChars "I" + , D.fromChars "recommend" + , D.fromChars "doing" + , D.fromChars "the" + , D.fromChars "conversion" + , D.fromChars "explicitly" + , D.fromChars "with" + , D.fromChars "one" + , D.fromChars "of" + , D.fromChars "these" + , D.fromChars "functions:" + ] + , D.vcat + [ D.green (D.fromChars "round") |> D.a (D.fromChars " 3.5 == 4") + , D.green (D.fromChars "floor") |> D.a (D.fromChars " 3.5 == 3") + , D.green (D.fromChars "ceiling") |> D.a (D.fromChars " 3.5 == 4") + , D.green (D.fromChars "truncate") |> D.a (D.fromChars " 3.5 == 3") + ] + , D.link "Note" "Read" "implicit-casts" "to learn why Elm does not implicitly convert Ints to Floats." + ] + + else + loneType localizer + tipe + expected + (D.fillSep + [ D.fromChars "The" + , direction + , D.fromChars "side" + , D.fromChars "of" + , D.fromChars "(//)" + , D.fromChars "must" + , D.fromChars "be" + , D.fromChars "an" + , D.dullyellow (D.fromChars "Int") |> D.a (D.fromChars ",") + , D.fromChars "but" + , D.fromChars "instead" + , D.fromChars "I" + , D.fromChars "am" + , D.fromChars "seeing:" + ] + ) + [] + ) + + + +-- BAD BOOLS + + +badBool : L.Localizer -> D.Doc -> D.Doc -> T.Type -> T.Type -> ( D.Doc, D.Doc ) +badBool localizer op direction tipe expected = + ( D.reflow "I am struggling with this boolean operation:" + , loneType localizer + tipe + expected + (D.fillSep + [ D.fromChars "Both" + , D.fromChars "sides" + , D.fromChars "of" + , D.fromChars "(" |> D.a op |> D.a (D.fromChars ")") + , D.fromChars "must" + , D.fromChars "be" + , D.dullyellow (D.fromChars "Bool") + , D.fromChars "values," + , D.fromChars "but" + , D.fromChars "the" + , direction + , D.fromChars "side" + , D.fromChars "is:" + ] + ) + [] + ) + + + +-- BAD COMPARISON + + +badCompLeft : L.Localizer -> Category -> String -> String -> T.Type -> T.Type -> ( D.Doc, D.Doc ) +badCompLeft localizer category op direction tipe expected = + ( D.reflow "I cannot do a comparison with this value:" + , loneType localizer + tipe + expected + (D.reflow (addCategory ("The " ++ direction ++ " side of (" ++ op ++ ") is") category)) + [ D.fillSep + [ D.fromChars "But" + , D.fromChars ("(" ++ op ++ ")") + , D.fromChars "only" + , D.fromChars "works" + , D.fromChars "on" + , D.dullyellow (D.fromChars "Int") |> D.a (D.fromChars ",") + , D.dullyellow (D.fromChars "Float") |> D.a (D.fromChars ",") + , D.dullyellow (D.fromChars "Char") |> D.a (D.fromChars ",") + , D.fromChars "and" + , D.dullyellow (D.fromChars "String") + , D.fromChars "values." + , D.fromChars "It" + , D.fromChars "can" + , D.fromChars "work" + , D.fromChars "on" + , D.fromChars "lists" + , D.fromChars "and" + , D.fromChars "tuples" + , D.fromChars "of" + , D.fromChars "comparable" + , D.fromChars "values" + , D.fromChars "as" + , D.fromChars "well," + , D.fromChars "but" + , D.fromChars "it" + , D.fromChars "is" + , D.fromChars "usually" + , D.fromChars "better" + , D.fromChars "to" + , D.fromChars "find" + , D.fromChars "a" + , D.fromChars "different" + , D.fromChars "path." + ] + ] + ) + + +badCompRight : L.Localizer -> String -> T.Type -> T.Type -> RightDocs +badCompRight localizer op tipe expected = + EmphBoth + ( D.reflow <| + ("I need both sides of (" ++ op ++ ") to be the same type:") + , typeComparison localizer + expected + tipe + ("The left side of (" ++ op ++ ") is:") + "But the right side is:" + [ D.reflow <| + ("I cannot compare different types though! Which side of (" ++ op ++ ") is the problem?") + ] + ) + + + +-- BAD EQUALITY + + +badEquality : L.Localizer -> String -> T.Type -> T.Type -> RightDocs +badEquality localizer op tipe expected = + EmphBoth + ( D.reflow <| + ("I need both sides of (" ++ op ++ ") to be the same type:") + , typeComparison localizer + expected + tipe + ("The left side of (" ++ op ++ ") is:") + "But the right side is:" + [ if isFloat tipe || isFloat expected then + D.toSimpleNote <| + "Equality on floats is not 100% reliable due to the design of IEEE 754. I recommend a check like (abs (x - y) < 0.0001) instead." + + else + D.reflow "Different types can never be equal though! Which side is messed up?" + ] + ) + + + +-- INFINITE TYPES + + +toInfiniteReport : Code.Source -> L.Localizer -> A.Region -> Name -> T.Type -> Report.Report +toInfiniteReport source localizer region name overallType = + Report.Report "INFINITE TYPE" region [] <| + Code.toSnippet source region Nothing <| + ( D.reflow <| + ("I am inferring a weird self-referential type for " ++ name ++ ":") + , D.stack + [ D.reflow <| + "Here is my best effort at writing down the type. You will see ∞ for parts of the type that repeat something already printed out infinitely." + , D.indent 4 (D.dullyellow (T.toDoc localizer RT.None overallType)) + , D.reflowLink + "Staring at this type is usually not so helpful, so I recommend reading the hints at" + "infinite-type" + "to get unstuck!" + ] + ) + + + +-- ENCODERS and DECODERS + + +errorEncoder : Error -> BE.Encoder +errorEncoder error = + case error of + BadExpr region category actualType expected -> + BE.sequence + [ BE.unsignedInt8 0 + , A.regionEncoder region + , categoryEncoder category + , T.typeEncoder actualType + , expectedEncoder T.typeEncoder expected + ] + + BadPattern region category tipe expected -> + BE.sequence + [ BE.unsignedInt8 1 + , A.regionEncoder region + , pCategoryEncoder category + , T.typeEncoder tipe + , pExpectedEncoder T.typeEncoder expected + ] + + InfiniteType region name overallType -> + BE.sequence + [ BE.unsignedInt8 2 + , A.regionEncoder region + , BE.string name + , T.typeEncoder overallType + ] + + +errorDecoder : BD.Decoder Error +errorDecoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.map4 BadExpr + A.regionDecoder + categoryDecoder + T.typeDecoder + (expectedDecoder T.typeDecoder) + + 1 -> + BD.map4 BadPattern + A.regionDecoder + pCategoryDecoder + T.typeDecoder + (pExpectedDecoder T.typeDecoder) + + 2 -> + BD.map3 InfiniteType + A.regionDecoder + BD.string + T.typeDecoder + + _ -> + BD.fail + ) + + +categoryEncoder : Category -> BE.Encoder +categoryEncoder category = + case category of + List -> + BE.unsignedInt8 0 + + Number -> + BE.unsignedInt8 1 + + Float -> + BE.unsignedInt8 2 + + String -> + BE.unsignedInt8 3 + + Char -> + BE.unsignedInt8 4 + + If -> + BE.unsignedInt8 5 + + Case -> + BE.unsignedInt8 6 + + CallResult maybeName -> + BE.sequence + [ BE.unsignedInt8 7 + , maybeNameEncoder maybeName + ] + + Lambda -> + BE.unsignedInt8 8 + + Accessor field -> + BE.sequence + [ BE.unsignedInt8 9 + , BE.string field + ] + + Access field -> + BE.sequence + [ BE.unsignedInt8 10 + , BE.string field + ] + + Record -> + BE.unsignedInt8 11 + + Tuple -> + BE.unsignedInt8 12 + + Unit -> + BE.unsignedInt8 13 + + Shader -> + BE.unsignedInt8 14 + + Effects -> + BE.unsignedInt8 15 + + Local name -> + BE.sequence + [ BE.unsignedInt8 16 + , BE.string name + ] + + Foreign name -> + BE.sequence + [ BE.unsignedInt8 17 + , BE.string name + ] + + +categoryDecoder : BD.Decoder Category +categoryDecoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.succeed List + + 1 -> + BD.succeed Number + + 2 -> + BD.succeed Float + + 3 -> + BD.succeed String + + 4 -> + BD.succeed Char + + 5 -> + BD.succeed If + + 6 -> + BD.succeed Case + + 7 -> + BD.map CallResult maybeNameDecoder + + 8 -> + BD.succeed Lambda + + 9 -> + BD.map Accessor BD.string + + 10 -> + BD.map Access BD.string + + 11 -> + BD.succeed Record + + 12 -> + BD.succeed Tuple + + 13 -> + BD.succeed Unit + + 14 -> + BD.succeed Shader + + 15 -> + BD.succeed Effects + + 16 -> + BD.map Local BD.string + + 17 -> + BD.map Foreign BD.string + + _ -> + BD.fail + ) + + +expectedEncoder : (a -> BE.Encoder) -> Expected a -> BE.Encoder +expectedEncoder encoder expected = + case expected of + NoExpectation expectedType -> + BE.sequence + [ BE.unsignedInt8 0 + , encoder expectedType + ] + + FromContext region context expectedType -> + BE.sequence + [ BE.unsignedInt8 1 + , A.regionEncoder region + , contextEncoder context + , encoder expectedType + ] + + FromAnnotation name arity subContext expectedType -> + BE.sequence + [ BE.unsignedInt8 2 + , BE.string name + , BE.int arity + , subContextEncoder subContext + , encoder expectedType + ] + + +expectedDecoder : BD.Decoder a -> BD.Decoder (Expected a) +expectedDecoder decoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.map NoExpectation + decoder + + 1 -> + BD.map3 FromContext + A.regionDecoder + contextDecoder + decoder + + 2 -> + BD.map4 FromAnnotation + BD.string + BD.int + subContextDecoder + decoder + + _ -> + BD.fail + ) + + +contextEncoder : Context -> BE.Encoder +contextEncoder context = + case context of + ListEntry index -> + BE.sequence + [ BE.unsignedInt8 0 + , Index.zeroBasedEncoder index + ] + + Negate -> + BE.unsignedInt8 1 + + OpLeft op -> + BE.sequence + [ BE.unsignedInt8 2 + , BE.string op + ] + + OpRight op -> + BE.sequence + [ BE.unsignedInt8 3 + , BE.string op + ] + + IfCondition -> + BE.unsignedInt8 4 + + IfBranch index -> + BE.sequence + [ BE.unsignedInt8 5 + , Index.zeroBasedEncoder index + ] + + CaseBranch index -> + BE.sequence + [ BE.unsignedInt8 6 + , Index.zeroBasedEncoder index + ] + + CallArity maybeFuncName numGivenArgs -> + BE.sequence + [ BE.unsignedInt8 7 + , maybeNameEncoder maybeFuncName + , BE.int numGivenArgs + ] + + CallArg maybeFuncName index -> + BE.sequence + [ BE.unsignedInt8 8 + , maybeNameEncoder maybeFuncName + , Index.zeroBasedEncoder index + ] + + RecordAccess recordRegion maybeName fieldRegion field -> + BE.sequence + [ BE.unsignedInt8 9 + , A.regionEncoder recordRegion + , BE.maybe BE.string maybeName + , A.regionEncoder fieldRegion + , BE.string field + ] + + RecordUpdateKeys expectedFields -> + BE.sequence + [ BE.unsignedInt8 10 + , BE.assocListDict compare BE.string Can.fieldUpdateEncoder expectedFields + ] + + RecordUpdateValue field -> + BE.sequence + [ BE.unsignedInt8 11 + , BE.string field + ] + + Destructure -> + BE.unsignedInt8 12 + + +contextDecoder : BD.Decoder Context +contextDecoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.map ListEntry Index.zeroBasedDecoder + + 1 -> + BD.succeed Negate + + 2 -> + BD.map OpLeft BD.string + + 3 -> + BD.map OpRight BD.string + + 4 -> + BD.succeed IfCondition + + 5 -> + BD.map IfBranch Index.zeroBasedDecoder + + 6 -> + BD.map CaseBranch Index.zeroBasedDecoder + + 7 -> + BD.map2 CallArity + maybeNameDecoder + BD.int + + 8 -> + BD.map2 CallArg + maybeNameDecoder + Index.zeroBasedDecoder + + 9 -> + BD.map4 RecordAccess + A.regionDecoder + (BD.maybe BD.string) + A.regionDecoder + BD.string + + 10 -> + BD.map RecordUpdateKeys + (BD.assocListDict identity BD.string Can.fieldUpdateDecoder) + + 11 -> + BD.map RecordUpdateValue BD.string + + 12 -> + BD.succeed Destructure + + _ -> + BD.fail + ) + + +subContextEncoder : SubContext -> BE.Encoder +subContextEncoder subContext = + case subContext of + TypedIfBranch index -> + BE.sequence + [ BE.unsignedInt8 0 + , Index.zeroBasedEncoder index + ] + + TypedCaseBranch index -> + BE.sequence + [ BE.unsignedInt8 1 + , Index.zeroBasedEncoder index + ] + + TypedBody -> + BE.unsignedInt8 2 + + +subContextDecoder : BD.Decoder SubContext +subContextDecoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.map TypedIfBranch Index.zeroBasedDecoder + + 1 -> + BD.map TypedCaseBranch Index.zeroBasedDecoder + + 2 -> + BD.succeed TypedBody + + _ -> + BD.fail + ) + + +pCategoryEncoder : PCategory -> BE.Encoder +pCategoryEncoder pCategory = + case pCategory of + PRecord -> + BE.unsignedInt8 0 + + PUnit -> + BE.unsignedInt8 1 + + PTuple -> + BE.unsignedInt8 2 + + PList -> + BE.unsignedInt8 3 + + PCtor name -> + BE.sequence + [ BE.unsignedInt8 4 + , BE.string name + ] + + PInt -> + BE.unsignedInt8 5 + + PStr -> + BE.unsignedInt8 6 + + PChr -> + BE.unsignedInt8 7 + + PBool -> + BE.unsignedInt8 8 + + +pCategoryDecoder : BD.Decoder PCategory +pCategoryDecoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.succeed PRecord + + 1 -> + BD.succeed PUnit + + 2 -> + BD.succeed PTuple + + 3 -> + BD.succeed PList + + 4 -> + BD.map PCtor BD.string + + 5 -> + BD.succeed PInt + + 6 -> + BD.succeed PStr + + 7 -> + BD.succeed PChr + + 8 -> + BD.succeed PBool + + _ -> + BD.fail + ) + + +pExpectedEncoder : (a -> BE.Encoder) -> PExpected a -> BE.Encoder +pExpectedEncoder encoder pExpected = + case pExpected of + PNoExpectation expectedType -> + BE.sequence + [ BE.unsignedInt8 0 + , encoder expectedType + ] + + PFromContext region context expectedType -> + BE.sequence + [ BE.unsignedInt8 1 + , A.regionEncoder region + , pContextEncoder context + , encoder expectedType + ] + + +pExpectedDecoder : BD.Decoder a -> BD.Decoder (PExpected a) +pExpectedDecoder decoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.map PNoExpectation decoder + + 1 -> + BD.map3 PFromContext + A.regionDecoder + pContextDecoder + decoder + + _ -> + BD.fail + ) + + +maybeNameEncoder : MaybeName -> BE.Encoder +maybeNameEncoder maybeName = + case maybeName of + FuncName name -> + BE.sequence + [ BE.unsignedInt8 0 + , BE.string name + ] + + CtorName name -> + BE.sequence + [ BE.unsignedInt8 1 + , BE.string name + ] + + OpName op -> + BE.sequence + [ BE.unsignedInt8 2 + , BE.string op + ] + + NoName -> + BE.unsignedInt8 3 + + +maybeNameDecoder : BD.Decoder MaybeName +maybeNameDecoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.map FuncName BD.string + + 1 -> + BD.map CtorName BD.string + + 2 -> + BD.map OpName BD.string + + 3 -> + BD.succeed NoName + + _ -> + BD.fail + ) + + +pContextEncoder : PContext -> BE.Encoder +pContextEncoder pContext = + case pContext of + PTypedArg name index -> + BE.sequence + [ BE.unsignedInt8 0 + , BE.string name + , Index.zeroBasedEncoder index + ] + + PCaseMatch index -> + BE.sequence + [ BE.unsignedInt8 1 + , Index.zeroBasedEncoder index + ] + + PCtorArg name index -> + BE.sequence + [ BE.unsignedInt8 2 + , BE.string name + , Index.zeroBasedEncoder index + ] + + PListEntry index -> + BE.sequence + [ BE.unsignedInt8 3 + , Index.zeroBasedEncoder index + ] + + PTail -> + BE.unsignedInt8 4 + + +pContextDecoder : BD.Decoder PContext +pContextDecoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.map2 PTypedArg + BD.string + Index.zeroBasedDecoder + + 1 -> + BD.map PCaseMatch Index.zeroBasedDecoder + + 2 -> + BD.map2 PCtorArg + BD.string + Index.zeroBasedDecoder + + 3 -> + BD.map PListEntry Index.zeroBasedDecoder + + 4 -> + BD.succeed PTail + + _ -> + BD.fail + ) diff --git a/src/Compiler/Reporting/Render/Code.elm b/src/Compiler/Reporting/Render/Code.elm new file mode 100644 index 0000000000..ae74f7f132 --- /dev/null +++ b/src/Compiler/Reporting/Render/Code.elm @@ -0,0 +1,327 @@ +module Compiler.Reporting.Render.Code exposing + ( Next(..) + , Source + , nextLineStartsWithCloseCurly + , nextLineStartsWithKeyword + , toPair + , toSnippet + , toSource + , whatIsNext + ) + +import Char +import Compiler.Parse.Primitives exposing (Col, Row) +import Compiler.Parse.Symbol exposing (binopCharSet) +import Compiler.Parse.Variable as Var +import Compiler.Reporting.Annotation as A +import Compiler.Reporting.Doc as D exposing (Doc) +import Data.Set as EverySet +import Prelude + + + +-- CODE + + +type alias Source = + List ( Int, String ) + + +toSource : String -> Source +toSource source = + List.indexedMap (\i line -> ( i + 1, line )) (String.lines source ++ [ "" ]) + + + +-- CODE FORMATTING + + +toSnippet : Source -> A.Region -> Maybe A.Region -> ( Doc, Doc ) -> Doc +toSnippet source region highlight ( preHint, postHint ) = + D.vcat + [ preHint + , D.fromChars "" + , render source region highlight + , postHint + ] + + +toPair : Source -> A.Region -> A.Region -> ( Doc, Doc ) -> ( Doc, Doc, Doc ) -> Doc +toPair source r1 r2 ( oneStart, oneEnd ) ( twoStart, twoMiddle, twoEnd ) = + case renderPair source r1 r2 of + OneLine codeDocs -> + D.vcat + [ oneStart + , D.fromChars "" + , codeDocs + , oneEnd + ] + + TwoChunks code1 code2 -> + D.vcat + [ twoStart + , D.fromChars "" + , code1 + , twoMiddle + , D.fromChars "" + , code2 + , twoEnd + ] + + + +-- RENDER SNIPPET + + +render : Source -> A.Region -> Maybe A.Region -> Doc +render sourceLines ((A.Region (A.Position startLine _) (A.Position endLine _)) as region) maybeSubRegion = + let + relevantLines : List ( Int, String ) + relevantLines = + sourceLines + |> List.drop (startLine - 1) + |> List.take (1 + endLine - startLine) + + width : Int + width = + String.length (String.fromInt (Tuple.first (Prelude.last relevantLines))) + + smallerRegion : A.Region + smallerRegion = + Maybe.withDefault region maybeSubRegion + in + case makeUnderline width endLine smallerRegion of + Nothing -> + drawLines True width smallerRegion relevantLines D.empty + + Just underline -> + drawLines False width smallerRegion relevantLines underline + + +makeUnderline : Int -> Int -> A.Region -> Maybe Doc +makeUnderline width realEndLine (A.Region (A.Position start c1) (A.Position end c2)) = + if start /= end || end < realEndLine then + Nothing + + else + let + spaces : String + spaces = + String.repeat (c1 + width + 1) " " + + zigzag : String + zigzag = + String.repeat (max 1 (c2 - c1)) "^" + in + Just + (D.fromChars spaces + |> D.a (D.red (D.fromChars zigzag)) + ) + + +drawLines : Bool -> Int -> A.Region -> Source -> Doc -> Doc +drawLines addZigZag width (A.Region (A.Position startLine _) (A.Position endLine _)) sourceLines finalLine = + D.vcat <| + List.map (drawLine addZigZag width startLine endLine) sourceLines + ++ [ finalLine ] + + +drawLine : Bool -> Int -> Int -> Int -> ( Int, String ) -> Doc +drawLine addZigZag width startLine endLine ( n, line ) = + addLineNumber addZigZag width startLine endLine n (D.fromChars line) + + +addLineNumber : Bool -> Int -> Int -> Int -> Int -> Doc -> Doc +addLineNumber addZigZag width start end n line = + let + number : String + number = + String.fromInt n + + lineNumber : String + lineNumber = + String.repeat (width - String.length number) " " ++ number ++ "|" + + spacer : Doc + spacer = + if addZigZag && start <= n && n <= end then + D.red (D.fromChars ">") + + else + D.fromChars " " + in + D.fromChars lineNumber |> D.a spacer |> D.a line + + + +-- RENDER PAIR + + +type CodePair + = OneLine Doc + | TwoChunks Doc Doc + + +renderPair : Source -> A.Region -> A.Region -> CodePair +renderPair source region1 region2 = + let + (A.Region (A.Position startRow1 startCol1) (A.Position endRow1 endCol1)) = + region1 + + (A.Region (A.Position startRow2 startCol2) (A.Position endRow2 endCol2)) = + region2 + in + if startRow1 == endRow1 && endRow1 == startRow2 && startRow2 == endRow2 then + let + lineNumber : String + lineNumber = + String.fromInt startRow1 + + spaces1 : String + spaces1 = + String.repeat (startCol1 + String.length lineNumber + 1) " " + + zigzag1 : String + zigzag1 = + String.repeat (endCol1 - startCol1) "^" + + spaces2 : String + spaces2 = + String.repeat (startCol2 - endCol1) " " + + zigzag2 : String + zigzag2 = + String.repeat (endCol2 - startCol2) "^" + + line : String + line = + List.head (List.filter (\( row, _ ) -> row == startRow1) source) |> Maybe.map Tuple.second |> Maybe.withDefault "" + in + OneLine + (D.vcat + [ D.fromChars (lineNumber ++ "| " ++ line) + , D.fromChars spaces1 + |> D.a (D.red (D.fromChars zigzag1)) + |> D.a (D.fromChars spaces2) + |> D.a (D.red (D.fromChars zigzag2)) + ] + ) + + else + TwoChunks + (render source region1 Nothing) + (render source region2 Nothing) + + + +-- WHAT IS NEXT? + + +type Next + = Keyword String + | Operator String + | Close String Char + | Upper Char String + | Lower Char String + | Other (Maybe Char) + + +whatIsNext : Source -> Row -> Col -> Next +whatIsNext sourceLines row col = + case List.head (List.filter (\( r, _ ) -> r == row) sourceLines) of + Nothing -> + Other Nothing + + Just ( _, line ) -> + case String.dropLeft (col - 1) line |> String.toList of + [] -> + Other Nothing + + c :: cs -> + if Char.isUpper c then + Upper c (List.filter isInner cs |> String.fromList) + + else if Char.isLower c then + detectKeywords c (String.fromList cs) + + else if isSymbol c then + Operator (c :: List.filter isSymbol cs |> String.fromList) + + else if c == ')' then + Close "parenthesis" ')' + + else if c == ']' then + Close "square bracket" ']' + + else if c == '}' then + Close "curly brace" '}' + + else + Other (Just c) + + +detectKeywords : Char -> String -> Next +detectKeywords c rest = + let + cs : String + cs = + List.filter isInner (String.toList rest) |> String.fromList + + name : String + name = + String.fromChar c ++ cs + in + if Var.isReservedWord name then + Keyword name + + else + Lower c name + + +isInner : Char -> Bool +isInner char = + Char.isAlphaNum char || char == '_' + + +isSymbol : Char -> Bool +isSymbol char = + EverySet.member identity (Char.toCode char) binopCharSet + + +startsWithKeyword : String -> String -> Bool +startsWithKeyword restOfLine keyword = + String.startsWith keyword restOfLine + && (case String.dropLeft (String.length keyword) restOfLine |> String.toList of + [] -> + True + + c :: _ -> + not (isInner c) + ) + + +nextLineStartsWithKeyword : String -> Source -> Row -> Maybe ( Row, Col ) +nextLineStartsWithKeyword keyword sourceLines row = + List.head (List.filter (\( r, _ ) -> r == row + 1) sourceLines) + |> Maybe.andThen + (\( _, line ) -> + if startsWithKeyword (String.trimLeft line) keyword then + Just ( row + 1, 1 + String.length (String.trimLeft line) ) + + else + Nothing + ) + + +nextLineStartsWithCloseCurly : Source -> Row -> Maybe ( Row, Col ) +nextLineStartsWithCloseCurly sourceLines row = + List.head (List.filter (\( r, _ ) -> r == row + 1) sourceLines) + |> Maybe.andThen + (\( _, line ) -> + case String.trimLeft line |> String.toList of + '}' :: _ -> + Just ( row + 1, 1 + String.length (String.trimLeft line) ) + + _ -> + Nothing + ) diff --git a/src/Compiler/Reporting/Render/Type.elm b/src/Compiler/Reporting/Render/Type.elm new file mode 100644 index 0000000000..49c66adb84 --- /dev/null +++ b/src/Compiler/Reporting/Render/Type.elm @@ -0,0 +1,261 @@ +module Compiler.Reporting.Render.Type exposing + ( Context(..) + , apply + , canToDoc + , lambda + , record + , srcToDoc + , tuple + , vrecord + , vrecordSnippet + ) + +import Compiler.AST.Canonical as Can +import Compiler.AST.Source as Src +import Compiler.Data.Name as Name +import Compiler.Reporting.Annotation as A +import Compiler.Reporting.Doc as D +import Compiler.Reporting.Render.Type.Localizer as L +import List.Extra as List + + + +-- TO DOC + + +type Context + = None + | Func + | App + + +lambda : Context -> D.Doc -> D.Doc -> List D.Doc -> D.Doc +lambda context arg1 arg2 args = + let + lambdaDoc : D.Doc + lambdaDoc = + D.align <| D.sep (arg1 :: List.map (\a -> D.plus a (D.fromChars "->")) (arg2 :: args)) + in + case context of + None -> + lambdaDoc + + Func -> + D.cat [ D.fromChars "(", lambdaDoc, D.fromChars ")" ] + + App -> + D.cat [ D.fromChars "(", lambdaDoc, D.fromChars ")" ] + + +apply : Context -> D.Doc -> List D.Doc -> D.Doc +apply context name args = + case args of + [] -> + name + + _ -> + let + applyDoc : D.Doc + applyDoc = + D.hang 4 <| D.sep (name :: args) + in + case context of + App -> + D.cat [ D.fromChars "(", applyDoc, D.fromChars ")" ] + + Func -> + applyDoc + + None -> + applyDoc + + +tuple : D.Doc -> D.Doc -> List D.Doc -> D.Doc +tuple a b cs = + let + entries : List D.Doc + entries = + List.interweave (D.fromChars "( " :: List.repeat (List.length (b :: cs)) (D.fromChars ", ")) (a :: b :: cs) + in + D.align <| D.sep [ D.cat entries, D.fromChars ")" ] + + +record : List ( D.Doc, D.Doc ) -> Maybe D.Doc -> D.Doc +record entries maybeExt = + case ( List.map entryToDoc entries, maybeExt ) of + ( [], Nothing ) -> + D.fromChars "{}" + + ( fields, Nothing ) -> + D.align <| + D.sep + [ D.cat + (List.interweave (D.fromChars "{ " :: List.repeat (List.length fields - 1) (D.fromChars ", ")) fields) + , D.fromChars "}" + ] + + ( fields, Just ext ) -> + D.align <| + D.sep + [ D.hang 4 <| + D.sep + [ D.fromChars "{ " |> D.plus ext + , D.cat + (List.interweave (D.fromChars "|" :: List.repeat (List.length fields - 1) (D.fromChars ", ")) fields) + ] + , D.fromChars "}" + ] + + +entryToDoc : ( D.Doc, D.Doc ) -> D.Doc +entryToDoc ( fieldName, fieldType ) = + D.hang 4 <| D.sep [ fieldName |> D.plus (D.fromChars ":"), fieldType ] + + +vrecordSnippet : ( D.Doc, D.Doc ) -> List ( D.Doc, D.Doc ) -> D.Doc +vrecordSnippet entry entries = + let + field : D.Doc + field = + D.fromChars "{" |> D.plus (entryToDoc entry) + + fields : List D.Doc + fields = + List.intersperse (D.fromChars ",") (List.map entryToDoc entries ++ [ D.fromChars "..." ]) + |> List.intersperse (D.fromChars " ") + in + D.vcat (field :: fields ++ [ D.fromChars "}" ]) + + +vrecord : List ( D.Doc, D.Doc ) -> Maybe D.Doc -> D.Doc +vrecord entries maybeExt = + case ( List.map entryToDoc entries, maybeExt ) of + ( [], Nothing ) -> + D.fromChars "{}" + + ( fields, Nothing ) -> + D.vcat <| + (List.interweave (D.fromChars "{" :: List.repeat (List.length fields - 1) (D.fromChars ",")) fields + |> List.intersperse (D.fromChars " ") + ) + ++ [ D.fromChars "}" ] + + ( fields, Just ext ) -> + D.vcat + [ D.hang 4 <| + D.vcat + [ D.plus (D.fromChars "{") ext + , D.cat + (List.interweave (D.fromChars "|" :: List.repeat (List.length fields - 1) (D.fromChars ",")) fields + |> List.intersperse (D.fromChars " ") + ) + ] + , D.fromChars "}" + ] + + + +-- SOURCE TYPE TO DOC + + +srcToDoc : Context -> Src.Type -> D.Doc +srcToDoc context (A.At _ tipe) = + case tipe of + Src.TLambda ( _, arg1 ) ( _, result ) -> + let + ( arg2, rest ) = + collectSrcArgs result + in + lambda context (srcToDoc Func arg1) (srcToDoc Func arg2) (List.map (srcToDoc Func) rest) + + Src.TVar name -> + D.fromName name + + Src.TType _ name args -> + apply context (D.fromName name) (List.map (Src.c1Value >> srcToDoc App) args) + + Src.TTypeQual _ home name args -> + apply context (D.fromName home |> D.a (D.fromChars ".") |> D.a (D.fromName name)) (List.map (Src.c1Value >> srcToDoc App) args) + + Src.TRecord fields maybeExt _ -> + record (List.map srcFieldToDocs fields) (Maybe.map (\( _, A.At _ ext ) -> D.fromName ext) maybeExt) + + Src.TUnit -> + D.fromChars "()" + + Src.TTuple ( _, a ) ( _, b ) cs -> + tuple (srcToDoc None a) (srcToDoc None b) (List.map (srcToDoc None) (List.map Src.c2EolValue cs)) + + Src.TParens ( _, tipe_ ) -> + srcToDoc context tipe_ + + +srcFieldToDocs : Src.C2 ( Src.C1 (A.Located Name.Name), Src.C1 Src.Type ) -> ( D.Doc, D.Doc ) +srcFieldToDocs ( _, ( ( _, A.At _ fieldName ), ( _, fieldType ) ) ) = + ( D.fromName fieldName, srcToDoc None fieldType ) + + +collectSrcArgs : Src.Type -> ( Src.Type, List Src.Type ) +collectSrcArgs tipe = + case tipe of + A.At _ (Src.TLambda ( _, a ) ( _, result )) -> + let + ( b, cs ) = + collectSrcArgs result + in + ( a, b :: cs ) + + _ -> + ( tipe, [] ) + + + +-- CANONICAL TYPE TO DOC + + +canToDoc : L.Localizer -> Context -> Can.Type -> D.Doc +canToDoc localizer context tipe = + case tipe of + Can.TLambda arg1 result -> + let + ( arg2, rest ) = + collectArgs result + in + lambda context (canToDoc localizer Func arg1) (canToDoc localizer Func arg2) (List.map (canToDoc localizer Func) rest) + + Can.TVar name -> + D.fromName name + + Can.TType home name args -> + apply context (L.toDoc localizer home name) (List.map (canToDoc localizer App) args) + + Can.TRecord fields ext -> + record (List.map (canFieldToDoc localizer) (Can.fieldsToList fields)) (Maybe.map D.fromName ext) + + Can.TUnit -> + D.fromChars "()" + + Can.TTuple a b cs -> + tuple (canToDoc localizer None a) (canToDoc localizer None b) (List.map (canToDoc localizer None) cs) + + Can.TAlias home name args _ -> + apply context (L.toDoc localizer home name) (List.map (canToDoc localizer App << Tuple.second) args) + + +canFieldToDoc : L.Localizer -> ( Name.Name, Can.Type ) -> ( D.Doc, D.Doc ) +canFieldToDoc localizer ( name, tipe ) = + ( D.fromName name, canToDoc localizer None tipe ) + + +collectArgs : Can.Type -> ( Can.Type, List Can.Type ) +collectArgs tipe = + case tipe of + Can.TLambda a rest -> + let + ( b, cs ) = + collectArgs rest + in + ( a, b :: cs ) + + _ -> + ( tipe, [] ) diff --git a/src/Compiler/Reporting/Render/Type/Localizer.elm b/src/Compiler/Reporting/Render/Type/Localizer.elm new file mode 100644 index 0000000000..224c1ffb9f --- /dev/null +++ b/src/Compiler/Reporting/Render/Type/Localizer.elm @@ -0,0 +1,185 @@ +module Compiler.Reporting.Render.Type.Localizer exposing + ( Localizer + , empty + , fromModule + , fromNames + , localizerDecoder + , localizerEncoder + , toChars + , toDoc + ) + +import Compiler.AST.Source as Src +import Compiler.Data.Name as Name exposing (Name) +import Compiler.Elm.ModuleName as ModuleName +import Compiler.Reporting.Annotation as A +import Compiler.Reporting.Doc as D +import Data.Map as Dict exposing (Dict) +import Data.Set as EverySet exposing (EverySet) +import System.TypeCheck.IO as IO +import Utils.Bytes.Decode as BD +import Utils.Bytes.Encode as BE + + + +-- LOCALIZER + + +type Localizer + = Localizer (Dict String Name Import) + + +type alias Import = + { alias : Maybe Name + , exposing_ : Exposing + } + + +type Exposing + = All + | Only (EverySet String Name) + + +empty : Localizer +empty = + Localizer Dict.empty + + + +-- LOCALIZE + + +toDoc : Localizer -> IO.Canonical -> Name -> D.Doc +toDoc localizer home name = + D.fromChars (toChars localizer home name) + + +toChars : Localizer -> IO.Canonical -> Name -> String +toChars (Localizer localizer) ((IO.Canonical _ home) as moduleName) name = + case Dict.get identity home localizer of + Nothing -> + home ++ "." ++ name + + Just import_ -> + case import_.exposing_ of + All -> + name + + Only set -> + if EverySet.member identity name set then + name + + else if name == Name.list && moduleName == ModuleName.list then + "List" + + else + Maybe.withDefault home import_.alias ++ "." ++ name + + + +-- FROM NAMES + + +fromNames : Dict String Name a -> Localizer +fromNames names = + Localizer (Dict.map (\_ _ -> { alias = Nothing, exposing_ = All }) names) + + + +-- FROM MODULE + + +fromModule : Src.Module -> Localizer +fromModule ((Src.Module _ _ _ _ imports _ _ _ _ _) as modul) = + Localizer <| + Dict.fromList identity <| + (( Src.getName modul, { alias = Nothing, exposing_ = All } ) :: List.map toPair imports) + + +toPair : Src.Import -> ( Name, Import ) +toPair (Src.Import ( _, A.At _ name ) alias_ ( _, exposing_ )) = + ( name + , Import (Maybe.map Src.c2Value alias_) (toExposing exposing_) + ) + + +toExposing : Src.Exposing -> Exposing +toExposing exposing_ = + case exposing_ of + Src.Open _ _ -> + All + + Src.Explicit (A.At _ exposedList) -> + Only (List.foldr addType EverySet.empty (List.map Src.c2Value exposedList)) + + +addType : Src.Exposed -> EverySet String Name -> EverySet String Name +addType exposed types = + case exposed of + Src.Lower _ -> + types + + Src.Upper (A.At _ name) _ -> + EverySet.insert identity name types + + Src.Operator _ _ -> + types + + + +-- ENCODERS and DECODERS + + +localizerEncoder : Localizer -> BE.Encoder +localizerEncoder (Localizer localizer) = + BE.assocListDict compare BE.string importEncoder localizer + + +localizerDecoder : BD.Decoder Localizer +localizerDecoder = + BD.map Localizer (BD.assocListDict identity BD.string importDecoder) + + +importEncoder : Import -> BE.Encoder +importEncoder import_ = + BE.sequence + [ BE.maybe BE.string import_.alias + , exposingEncoder import_.exposing_ + ] + + +importDecoder : BD.Decoder Import +importDecoder = + BD.map2 Import + (BD.maybe BD.string) + exposingDecoder + + +exposingEncoder : Exposing -> BE.Encoder +exposingEncoder exposing_ = + case exposing_ of + All -> + BE.unsignedInt8 0 + + Only set -> + BE.sequence + [ BE.unsignedInt8 1 + , BE.everySet compare BE.string set + ] + + +exposingDecoder : BD.Decoder Exposing +exposingDecoder = + BD.unsignedInt8 + |> BD.andThen + (\type_ -> + case type_ of + 0 -> + BD.succeed All + + 1 -> + BD.map Only (BD.everySet identity BD.string) + + _ -> + BD.fail + ) diff --git a/src/Compiler/Reporting/Report.elm b/src/Compiler/Reporting/Report.elm new file mode 100644 index 0000000000..2877fd85bb --- /dev/null +++ b/src/Compiler/Reporting/Report.elm @@ -0,0 +1,12 @@ +module Compiler.Reporting.Report exposing (Report(..)) + +import Compiler.Reporting.Annotation as A +import Compiler.Reporting.Doc as D + + + +-- BUILD REPORTS + + +type Report + = Report String A.Region (List String) D.Doc diff --git a/src/Compiler/Reporting/Result.elm b/src/Compiler/Reporting/Result.elm new file mode 100644 index 0000000000..1393535f87 --- /dev/null +++ b/src/Compiler/Reporting/Result.elm @@ -0,0 +1,215 @@ +module Compiler.Reporting.Result exposing + ( RResult(..) + , RStep(..) + , Step(..) + , apply + , bind + , fmap + , indexedTraverse + , loop + , mapTraverseWithKey + , ok + , pure + , run + , throw + , traverse + , traverseDict + , warn + ) + +import Compiler.Data.Index as Index +import Compiler.Data.OneOrMore as OneOrMore +import Compiler.Reporting.Warning as Warning +import Data.Map as Dict exposing (Dict) + + + +-- RESULT + + +type RResult info warnings error a + = RResult (info -> warnings -> RStep info warnings error a) + + +type RStep info warnings error a + = ROk info warnings a + | RErr info warnings (OneOrMore.OneOrMore error) + + +run : RResult () (List w) e a -> ( List w, Result (OneOrMore.OneOrMore e) a ) +run (RResult k) = + case k () [] of + ROk () w a -> + ( List.reverse w, Ok a ) + + RErr () w e -> + ( List.reverse w, Err e ) + + + +-- LOOP + + +type Step state a + = Loop state + | Done a + + +loop : (state -> RResult i w e (Step state a)) -> state -> RResult i w e a +loop callback state = + RResult <| + \i w -> + loopHelp callback i w state + + +loopHelp : (state -> RResult i w e (Step state a)) -> i -> w -> state -> RStep i w e a +loopHelp callback i w state = + case callback state of + RResult k -> + case k i w of + RErr i1 w1 e -> + RErr i1 w1 e + + ROk i1 w1 (Loop newState) -> + loopHelp callback i1 w1 newState + + ROk i1 w1 (Done a) -> + ROk i1 w1 a + + + +-- HELPERS + + +ok : a -> RResult i w e a +ok a = + RResult <| + \i w -> + ROk i w a + + +warn : Warning.Warning -> RResult i (List Warning.Warning) e () +warn warning = + RResult <| + \i warnings -> + ROk i (warning :: warnings) () + + +throw : e -> RResult i w e a +throw e = + RResult <| + \i w -> + RErr i w (OneOrMore.one e) + + + +-- FANCY INSTANCE STUFF + + +fmap : (a -> b) -> RResult i w e a -> RResult i w e b +fmap func (RResult k) = + RResult <| + \i w -> + case k i w of + ROk i1 w1 value -> + ROk i1 w1 (func value) + + RErr i1 w1 e -> + RErr i1 w1 e + + +pure : a -> RResult i w e a +pure = + ok + + +apply : RResult i w x a -> RResult i w x (a -> b) -> RResult i w x b +apply (RResult kv) (RResult kf) = + RResult <| + \i w -> + case kf i w of + ROk i1 w1 func -> + case kv i1 w1 of + ROk i2 w2 value -> + ROk i2 w2 (func value) + + RErr i2 w2 e2 -> + RErr i2 w2 e2 + + RErr i1 w1 e1 -> + case kv i1 w1 of + ROk i2 w2 _ -> + RErr i2 w2 e1 + + RErr i2 w2 e2 -> + RErr i2 w2 (OneOrMore.more e1 e2) + + +bind : (a -> RResult i w x b) -> RResult i w x a -> RResult i w x b +bind callback (RResult ka) = + RResult <| + \i w -> + case ka i w of + ROk i1 w1 a -> + case callback a of + RResult kb -> + kb i1 w1 + + RErr i1 w1 e -> + RErr i1 w1 e + + +traverse : (a -> RResult i w x b) -> List a -> RResult i w x (List b) +traverse func = + List.foldl + (\a (RResult acc) -> + RResult <| + \i w -> + let + (RResult kv) = + func a + in + case acc i w of + ROk i1 w1 accList -> + case kv i1 w1 of + ROk i2 w2 value -> + ROk i2 w2 (value :: accList) + + RErr i2 w2 e2 -> + RErr i2 w2 e2 + + RErr i1 w1 e1 -> + case kv i1 w1 of + ROk i2 w2 _ -> + RErr i2 w2 e1 + + RErr i2 w2 e2 -> + RErr i2 w2 (OneOrMore.more e1 e2) + ) + (pure []) + >> fmap List.reverse + + +mapTraverseWithKey : (k -> comparable) -> (k -> k -> Order) -> (k -> a -> RResult i w x b) -> Dict comparable k a -> RResult i w x (Dict comparable k b) +mapTraverseWithKey toComparable keyComparison f dict = + loop (mapTraverseWithKeyHelp toComparable f) ( Dict.toList keyComparison dict, Dict.empty ) + + +mapTraverseWithKeyHelp : (k -> comparable) -> (k -> a -> RResult i w x b) -> ( List ( k, a ), Dict comparable k b ) -> RResult i w x (Step ( List ( k, a ), Dict comparable k b ) (Dict comparable k b)) +mapTraverseWithKeyHelp toComparable f ( pairs, result ) = + case pairs of + [] -> + pure (Done result) + + ( k, a ) :: rest -> + fmap (\b -> Loop ( rest, Dict.insert toComparable k b result )) (f k a) + + +traverseDict : (k -> comparable) -> (k -> k -> Order) -> (a -> RResult i w x b) -> Dict comparable k a -> RResult i w x (Dict comparable k b) +traverseDict toComparable keyComparison func = + Dict.foldr keyComparison (\k a -> bind (\acc -> fmap (\b -> Dict.insert toComparable k b acc) (func a))) (ok Dict.empty) + + +indexedTraverse : (Index.ZeroBased -> a -> RResult i w error b) -> List a -> RResult i w error (List b) +indexedTraverse func xs = + List.foldr (\a -> bind (\acc -> fmap (\b -> b :: acc) a)) (ok []) (Index.indexedMap func xs) diff --git a/src/Compiler/Reporting/Suggest.elm b/src/Compiler/Reporting/Suggest.elm new file mode 100644 index 0000000000..7acb919bb6 --- /dev/null +++ b/src/Compiler/Reporting/Suggest.elm @@ -0,0 +1,47 @@ +module Compiler.Reporting.Suggest exposing + ( distance + , rank + , sort + ) + +import Levenshtein + + + +-- DISTANCE + + +distance : String -> String -> Int +distance = + Levenshtein.distance + + + +-- SORT + + +sort : String -> (a -> String) -> List a -> List a +sort target toString = + List.sortBy + (distance (String.toLower target) + << String.toLower + << toString + ) + + + +-- RANK + + +rank : String -> (a -> String) -> List a -> List ( Int, a ) +rank target toString values = + let + toRank : a -> Int + toRank v = + distance (String.toLower target) (String.toLower (toString v)) + + addRank : a -> ( Int, a ) + addRank v = + ( toRank v, v ) + in + List.sortBy Tuple.first (List.map addRank values) diff --git a/src/Compiler/Reporting/Warning.elm b/src/Compiler/Reporting/Warning.elm new file mode 100644 index 0000000000..6987e728f3 --- /dev/null +++ b/src/Compiler/Reporting/Warning.elm @@ -0,0 +1,100 @@ +module Compiler.Reporting.Warning exposing + ( Context(..) + , Warning(..) + , toReport + ) + +import Compiler.AST.Canonical as Can +import Compiler.AST.Utils.Type as Type +import Compiler.Data.Name exposing (Name) +import Compiler.Reporting.Annotation as A +import Compiler.Reporting.Doc as D +import Compiler.Reporting.Render.Code as Code +import Compiler.Reporting.Render.Type as RT +import Compiler.Reporting.Render.Type.Localizer as L +import Compiler.Reporting.Report exposing (Report(..)) + + + +-- ALL POSSIBLE WARNINGS + + +type Warning + = UnusedImport A.Region Name + | UnusedVariable A.Region Context Name + | MissingTypeAnnotation A.Region Name Can.Type + + +type Context + = Def + | Pattern + + + +-- TO REPORT + + +toReport : L.Localizer -> Code.Source -> Warning -> Report +toReport localizer source warning = + case warning of + UnusedImport region moduleName -> + Report "unused import" region [] <| + Code.toSnippet source region Nothing <| + ( D.reflow ("Nothing from the `" ++ moduleName ++ "` module is used in this file.") + , D.fromChars "I recommend removing unused imports." + ) + + UnusedVariable region context name -> + let + title : String + title = + defOrPat context "unused definition" "unused variable" + in + Report title region [] <| + Code.toSnippet source region Nothing <| + ( D.reflow ("You are not using `" ++ name ++ "` anywhere.") + , D.stack + [ D.reflow <| + "Is there a typo? Maybe you intended to use `" + ++ name + ++ "` somewhere but typed another name instead?" + , D.reflow <| + defOrPat context + "If you are sure there is no typo, remove the definition. This way future readers will not have to wonder why it is there!" + ("If you are sure there is no typo, replace `" + ++ name + ++ "` with _ so future readers will not have to wonder why it is there!" + ) + ] + ) + + MissingTypeAnnotation region name inferredType -> + Report "missing type annotation" region [] <| + Code.toSnippet source region Nothing <| + ( D.reflow <| + case Type.deepDealias inferredType of + Can.TLambda _ _ -> + "The `" ++ name ++ "` function has no type annotation." + + _ -> + "The `" ++ name ++ "` definition has no type annotation." + , D.stack + [ D.fromChars "I inferred the type annotation myself though! You can copy it into your code:" + , D.green <| + D.hang 4 <| + D.sep + [ D.fromName name |> D.a (D.fromChars " :") + , RT.canToDoc localizer RT.None inferredType + ] + ] + ) + + +defOrPat : Context -> a -> a -> a +defOrPat context def pat = + case context of + Def -> + def + + Pattern -> + pat diff --git a/src/Compiler/Type/Constrain/Expression.elm b/src/Compiler/Type/Constrain/Expression.elm new file mode 100644 index 0000000000..b5702ae840 --- /dev/null +++ b/src/Compiler/Type/Constrain/Expression.elm @@ -0,0 +1,1095 @@ +module Compiler.Type.Constrain.Expression exposing + ( RTV + , constrainDef + , constrainRecursiveDefs + ) + +import Compiler.AST.Canonical as Can +import Compiler.AST.Utils.Shader as Shader +import Compiler.Data.Index as Index +import Compiler.Data.Name as Name exposing (Name) +import Compiler.Elm.ModuleName as ModuleName +import Compiler.Reporting.Annotation as A +import Compiler.Reporting.Error.Type as E exposing (Category(..), Context(..), Expected(..), MaybeName(..), PContext(..), PExpected(..), SubContext(..)) +import Compiler.Type.Constrain.Pattern as Pattern +import Compiler.Type.Instantiate as Instantiate +import Compiler.Type.Type as Type exposing (Constraint(..), Type(..)) +import Data.Map as Dict exposing (Dict) +import System.TypeCheck.IO as IO exposing (IO) +import Utils.Main as Utils + + + +-- CONSTRAIN + + +{-| As we step past type annotations, the free type variables are added to +the "rigid type variables" dict. Allowing sharing of rigid variables +between nested type annotations. + +So if you have a top-level type annotation like (func : a -> b) the RTV +dictionary will hold variables for `a` and `b` + +-} +type alias RTV = + Dict String Name.Name Type + + +constrain : RTV -> Can.Expr -> E.Expected Type -> IO Constraint +constrain rtv (A.At region expression) expected = + case expression of + Can.VarLocal name -> + IO.pure (CLocal region name expected) + + Can.VarTopLevel _ name -> + IO.pure (CLocal region name expected) + + Can.VarKernel _ _ -> + IO.pure CTrue + + Can.VarForeign _ name annotation -> + IO.pure (CForeign region name annotation expected) + + Can.VarCtor _ _ name _ annotation -> + IO.pure (CForeign region name annotation expected) + + Can.VarDebug _ name annotation -> + IO.pure (CForeign region name annotation expected) + + Can.VarOperator op _ _ annotation -> + IO.pure (CForeign region op annotation expected) + + Can.Str _ -> + IO.pure (CEqual region String Type.string expected) + + Can.Chr _ -> + IO.pure (CEqual region Char Type.char expected) + + Can.Int _ -> + Type.mkFlexNumber + |> IO.fmap + (\var -> + Type.exists [ var ] (CEqual region E.Number (VarN var) expected) + ) + + Can.Float _ -> + IO.pure (CEqual region Float Type.float expected) + + Can.List elements -> + constrainList rtv region elements expected + + Can.Negate expr -> + Type.mkFlexNumber + |> IO.bind + (\numberVar -> + let + numberType : Type + numberType = + VarN numberVar + in + constrain rtv expr (FromContext region Negate numberType) + |> IO.fmap + (\numberCon -> + let + negateCon : Constraint + negateCon = + CEqual region E.Number numberType expected + in + Type.exists [ numberVar ] (CAnd [ numberCon, negateCon ]) + ) + ) + + Can.Binop op _ _ annotation leftExpr rightExpr -> + constrainBinop rtv region op annotation leftExpr rightExpr expected + + Can.Lambda args body -> + constrainLambda rtv region args body expected + + Can.Call func args -> + constrainCall rtv region func args expected + + Can.If branches finally -> + constrainIf rtv region branches finally expected + + Can.Case expr branches -> + constrainCase rtv region expr branches expected + + Can.Let def body -> + IO.bind (constrainDef rtv def) + (constrain rtv body expected) + + Can.LetRec defs body -> + IO.bind (constrainRecursiveDefs rtv defs) + (constrain rtv body expected) + + Can.LetDestruct pattern expr body -> + IO.bind (constrainDestruct rtv region pattern expr) + (constrain rtv body expected) + + Can.Accessor field -> + Type.mkFlexVar + |> IO.bind + (\extVar -> + Type.mkFlexVar + |> IO.fmap + (\fieldVar -> + let + extType : Type + extType = + VarN extVar + + fieldType : Type + fieldType = + VarN fieldVar + + recordType : Type + recordType = + RecordN (Dict.singleton identity field fieldType) extType + in + Type.exists [ fieldVar, extVar ] (CEqual region (Accessor field) (FunN recordType fieldType) expected) + ) + ) + + Can.Access expr (A.At accessRegion field) -> + Type.mkFlexVar + |> IO.bind + (\extVar -> + Type.mkFlexVar + |> IO.bind + (\fieldVar -> + let + extType : Type + extType = + VarN extVar + + fieldType : Type + fieldType = + VarN fieldVar + + recordType : Type + recordType = + RecordN (Dict.singleton identity field fieldType) extType + + context : Context + context = + RecordAccess (A.toRegion expr) (getAccessName expr) accessRegion field + in + constrain rtv expr (FromContext region context recordType) + |> IO.fmap + (\recordCon -> + Type.exists [ fieldVar, extVar ] (CAnd [ recordCon, CEqual region (Access field) fieldType expected ]) + ) + ) + ) + + Can.Update expr fields -> + constrainUpdate rtv region expr fields expected + + Can.Record fields -> + constrainRecord rtv region fields expected + + Can.Unit -> + IO.pure (CEqual region Unit UnitN expected) + + Can.Tuple a b cs -> + constrainTuple rtv region a b cs expected + + Can.Shader _ types -> + constrainShader region types expected + + + +-- CONSTRAIN LAMBDA + + +constrainLambda : RTV -> A.Region -> List Can.Pattern -> Can.Expr -> E.Expected Type -> IO Constraint +constrainLambda rtv region args body expected = + constrainArgs args + |> IO.bind + (\(Args vars tipe resultType (Pattern.State headers pvars revCons)) -> + constrain rtv body (NoExpectation resultType) + |> IO.fmap + (\bodyCon -> + Type.exists vars <| + CAnd + [ CLet [] + pvars + headers + (CAnd (List.reverse revCons)) + bodyCon + , CEqual region Lambda tipe expected + ] + ) + ) + + + +-- CONSTRAIN CALL + + +constrainCall : RTV -> A.Region -> Can.Expr -> List Can.Expr -> E.Expected Type -> IO Constraint +constrainCall rtv region ((A.At funcRegion _) as func) args expected = + let + maybeName : MaybeName + maybeName = + getName func + in + Type.mkFlexVar + |> IO.bind + (\funcVar -> + Type.mkFlexVar + |> IO.bind + (\resultVar -> + let + funcType : Type + funcType = + VarN funcVar + + resultType : Type + resultType = + VarN resultVar + in + constrain rtv func (E.NoExpectation funcType) + |> IO.bind + (\funcCon -> + IO.fmap Utils.unzip3 (IO.traverseIndexed (constrainArg rtv region maybeName) args) + |> IO.fmap + (\( argVars, argTypes, argCons ) -> + let + arityType : Type + arityType = + List.foldr FunN resultType argTypes + + category : Category + category = + CallResult maybeName + in + Type.exists (funcVar :: resultVar :: argVars) + (CAnd + [ funcCon + , CEqual funcRegion category funcType (FromContext region (CallArity maybeName (List.length args)) arityType) + , CAnd argCons + , CEqual region category resultType expected + ] + ) + ) + ) + ) + ) + + +constrainArg : RTV -> A.Region -> E.MaybeName -> Index.ZeroBased -> Can.Expr -> IO ( IO.Variable, Type, Constraint ) +constrainArg rtv region maybeName index arg = + Type.mkFlexVar + |> IO.bind + (\argVar -> + let + argType : Type + argType = + VarN argVar + in + constrain rtv arg (FromContext region (CallArg maybeName index) argType) + |> IO.fmap + (\argCon -> + ( argVar, argType, argCon ) + ) + ) + + +getName : Can.Expr -> MaybeName +getName (A.At _ expr) = + case expr of + Can.VarLocal name -> + FuncName name + + Can.VarTopLevel _ name -> + FuncName name + + Can.VarForeign _ name _ -> + FuncName name + + Can.VarCtor _ _ name _ _ -> + CtorName name + + Can.VarOperator op _ _ _ -> + OpName op + + Can.VarKernel _ name -> + FuncName name + + _ -> + NoName + + +getAccessName : Can.Expr -> Maybe Name.Name +getAccessName (A.At _ expr) = + case expr of + Can.VarLocal name -> + Just name + + Can.VarTopLevel _ name -> + Just name + + Can.VarForeign _ name _ -> + Just name + + _ -> + Nothing + + + +-- CONSTRAIN BINOP + + +constrainBinop : RTV -> A.Region -> Name.Name -> Can.Annotation -> Can.Expr -> Can.Expr -> E.Expected Type -> IO Constraint +constrainBinop rtv region op annotation leftExpr rightExpr expected = + Type.mkFlexVar + |> IO.bind + (\leftVar -> + Type.mkFlexVar + |> IO.bind + (\rightVar -> + Type.mkFlexVar + |> IO.bind + (\answerVar -> + let + leftType : Type + leftType = + VarN leftVar + + rightType : Type + rightType = + VarN rightVar + + answerType : Type + answerType = + VarN answerVar + + binopType : Type + binopType = + Type.funType leftType (Type.funType rightType answerType) + + opCon : Constraint + opCon = + CForeign region op annotation (NoExpectation binopType) + in + constrain rtv leftExpr (FromContext region (OpLeft op) leftType) + |> IO.bind + (\leftCon -> + constrain rtv rightExpr (FromContext region (OpRight op) rightType) + |> IO.fmap + (\rightCon -> + Type.exists [ leftVar, rightVar, answerVar ] + (CAnd + [ opCon + , leftCon + , rightCon + , CEqual region (CallResult (OpName op)) answerType expected + ] + ) + ) + ) + ) + ) + ) + + + +-- CONSTRAIN LISTS + + +constrainList : RTV -> A.Region -> List Can.Expr -> E.Expected Type -> IO Constraint +constrainList rtv region entries expected = + Type.mkFlexVar + |> IO.bind + (\entryVar -> + let + entryType : Type + entryType = + VarN entryVar + + listType : Type + listType = + AppN ModuleName.list Name.list [ entryType ] + in + IO.traverseIndexed (constrainListEntry rtv region entryType) entries + |> IO.fmap + (\entryCons -> + Type.exists [ entryVar ] + (CAnd + [ CAnd entryCons + , CEqual region List listType expected + ] + ) + ) + ) + + +constrainListEntry : RTV -> A.Region -> Type -> Index.ZeroBased -> Can.Expr -> IO Constraint +constrainListEntry rtv region tipe index expr = + constrain rtv expr (FromContext region (ListEntry index) tipe) + + + +-- CONSTRAIN IF EXPRESSIONS + + +constrainIf : RTV -> A.Region -> List ( Can.Expr, Can.Expr ) -> Can.Expr -> E.Expected Type -> IO Constraint +constrainIf rtv region branches final expected = + let + boolExpect : Expected Type + boolExpect = + FromContext region IfCondition Type.bool + + ( conditions, exprs ) = + List.foldr (\( c, e ) ( cs, es ) -> ( c :: cs, e :: es )) ( [], [ final ] ) branches + in + IO.traverseList (\c -> constrain rtv c boolExpect) conditions + |> IO.bind + (\condCons -> + case expected of + FromAnnotation name arity _ tipe -> + IO.indexedForA exprs (\index expr -> constrain rtv expr (FromAnnotation name arity (TypedIfBranch index) tipe)) + |> IO.fmap + (\branchCons -> + CAnd (CAnd condCons :: branchCons) + ) + + _ -> + Type.mkFlexVar + |> IO.bind + (\branchVar -> + let + branchType : Type + branchType = + VarN branchVar + in + IO.indexedForA exprs + (\index expr -> + constrain rtv expr (FromContext region (IfBranch index) branchType) + ) + |> IO.fmap + (\branchCons -> + Type.exists [ branchVar ] + (CAnd + [ CAnd condCons + , CAnd branchCons + , CEqual region If branchType expected + ] + ) + ) + ) + ) + + + +-- CONSTRAIN CASE EXPRESSIONS + + +constrainCase : RTV -> A.Region -> Can.Expr -> List Can.CaseBranch -> Expected Type -> IO Constraint +constrainCase rtv region expr branches expected = + Type.mkFlexVar + |> IO.bind + (\ptrnVar -> + let + ptrnType : Type + ptrnType = + VarN ptrnVar + in + constrain rtv expr (NoExpectation ptrnType) + |> IO.bind + (\exprCon -> + case expected of + FromAnnotation name arity _ tipe -> + IO.indexedForA branches + (\index branch -> + constrainCaseBranch rtv + branch + (PFromContext region (PCaseMatch index) ptrnType) + (FromAnnotation name arity (TypedCaseBranch index) tipe) + ) + |> IO.fmap + (\branchCons -> + Type.exists [ ptrnVar ] (CAnd (exprCon :: branchCons)) + ) + + _ -> + Type.mkFlexVar + |> IO.bind + (\branchVar -> + let + branchType : Type + branchType = + VarN branchVar + in + IO.indexedForA branches + (\index branch -> + constrainCaseBranch rtv + branch + (PFromContext region (PCaseMatch index) ptrnType) + (FromContext region (CaseBranch index) branchType) + ) + |> IO.fmap + (\branchCons -> + Type.exists [ ptrnVar, branchVar ] + (CAnd + [ exprCon + , CAnd branchCons + , CEqual region Case branchType expected + ] + ) + ) + ) + ) + ) + + +constrainCaseBranch : RTV -> Can.CaseBranch -> PExpected Type -> Expected Type -> IO Constraint +constrainCaseBranch rtv (Can.CaseBranch pattern expr) pExpect bExpect = + Pattern.add pattern pExpect Pattern.emptyState + |> IO.bind + (\(Pattern.State headers pvars revCons) -> + IO.fmap (CLet [] pvars headers (CAnd (List.reverse revCons))) + (constrain rtv expr bExpect) + ) + + + +-- CONSTRAIN RECORD + + +constrainRecord : RTV -> A.Region -> Dict String (A.Located Name.Name) Can.Expr -> Expected Type -> IO Constraint +constrainRecord rtv region fields expected = + IO.traverseMap A.toValue A.compareLocated (constrainField rtv) fields + |> IO.fmap + (\dict -> + let + getType : a -> ( b, c, d ) -> c + getType _ ( _, t, _ ) = + t + + recordType : Type + recordType = + RecordN (Utils.mapMapKeys identity A.compareLocated A.toValue (Dict.map getType dict)) EmptyRecordN + + recordCon : Constraint + recordCon = + CEqual region Record recordType expected + + vars : List IO.Variable + vars = + Dict.foldr A.compareLocated (\_ ( v, _, _ ) vs -> v :: vs) [] dict + + cons : List Constraint + cons = + Dict.foldr A.compareLocated (\_ ( _, _, c ) cs -> c :: cs) [ recordCon ] dict + in + Type.exists vars (CAnd cons) + ) + + +constrainField : RTV -> Can.Expr -> IO ( IO.Variable, Type, Constraint ) +constrainField rtv expr = + Type.mkFlexVar + |> IO.bind + (\var -> + let + tipe : Type + tipe = + VarN var + in + constrain rtv expr (NoExpectation tipe) + |> IO.fmap + (\con -> + ( var, tipe, con ) + ) + ) + + + +-- CONSTRAIN RECORD UPDATE + + +constrainUpdate : RTV -> A.Region -> Can.Expr -> Dict String (A.Located Name.Name) Can.FieldUpdate -> Expected Type -> IO Constraint +constrainUpdate rtv region expr locatedFields expected = + Type.mkFlexVar + |> IO.bind + (\extVar -> + let + fields : Dict String Name.Name Can.FieldUpdate + fields = + Utils.mapMapKeys identity A.compareLocated A.toValue locatedFields + in + IO.traverseMapWithKey identity compare (constrainUpdateField rtv region) fields + |> IO.bind + (\fieldDict -> + Type.mkFlexVar + |> IO.bind + (\recordVar -> + let + recordType : Type + recordType = + VarN recordVar + + fieldsType : Type + fieldsType = + RecordN (Dict.map (\_ ( _, t, _ ) -> t) fieldDict) (VarN extVar) + + -- NOTE: fieldsType is separate so that Error propagates better + fieldsCon : Constraint + fieldsCon = + CEqual region Record recordType (NoExpectation fieldsType) + + recordCon : Constraint + recordCon = + CEqual region Record recordType expected + + vars : List IO.Variable + vars = + Dict.foldr compare (\_ ( v, _, _ ) vs -> v :: vs) [ recordVar, extVar ] fieldDict + + cons : List Constraint + cons = + Dict.foldr compare (\_ ( _, _, c ) cs -> c :: cs) [ recordCon ] fieldDict + in + constrain rtv expr (FromContext region (RecordUpdateKeys fields) recordType) + |> IO.fmap (\con -> Type.exists vars (CAnd (fieldsCon :: con :: cons))) + ) + ) + ) + + +constrainUpdateField : RTV -> A.Region -> Name.Name -> Can.FieldUpdate -> IO ( IO.Variable, Type, Constraint ) +constrainUpdateField rtv region field (Can.FieldUpdate _ expr) = + Type.mkFlexVar + |> IO.bind + (\var -> + let + tipe : Type + tipe = + VarN var + in + constrain rtv expr (FromContext region (RecordUpdateValue field) tipe) + |> IO.fmap (\con -> ( var, tipe, con )) + ) + + + +-- CONSTRAIN TUPLE + + +constrainTuple : RTV -> A.Region -> Can.Expr -> Can.Expr -> List Can.Expr -> Expected Type -> IO Constraint +constrainTuple rtv region a b cs expected = + Type.mkFlexVar + |> IO.bind + (\aVar -> + Type.mkFlexVar + |> IO.bind + (\bVar -> + let + aType : Type + aType = + VarN aVar + + bType : Type + bType = + VarN bVar + in + constrain rtv a (NoExpectation aType) + |> IO.bind + (\aCon -> + constrain rtv b (NoExpectation bType) + |> IO.bind + (\bCon -> + List.foldr + (\c -> + IO.bind + (\( cons, vars ) -> + Type.mkFlexVar + |> IO.bind + (\cVar -> + constrain rtv c (NoExpectation (VarN cVar)) + |> IO.fmap (\cCon -> ( cCon :: cons, cVar :: vars )) + ) + ) + ) + (IO.pure ( [], [] )) + cs + |> IO.fmap + (\( cons, vars ) -> + let + tupleType : Type + tupleType = + TupleN aType bType (List.map VarN vars) + + tupleCon : Constraint + tupleCon = + CEqual region Tuple tupleType expected + in + Type.exists (aVar :: bVar :: vars) (CAnd (aCon :: bCon :: cons ++ [ tupleCon ])) + ) + ) + ) + ) + ) + + + +-- CONSTRAIN SHADER + + +constrainShader : A.Region -> Shader.Types -> Expected Type -> IO Constraint +constrainShader region (Shader.Types attributes uniforms varyings) expected = + Type.mkFlexVar + |> IO.bind + (\attrVar -> + Type.mkFlexVar + |> IO.fmap + (\unifVar -> + let + attrType : Type + attrType = + VarN attrVar + + unifType : Type + unifType = + VarN unifVar + + shaderType : Type + shaderType = + AppN ModuleName.webgl + Name.shader + [ toShaderRecord attributes attrType + , toShaderRecord uniforms unifType + , toShaderRecord varyings EmptyRecordN + ] + in + Type.exists [ attrVar, unifVar ] (CEqual region Shader shaderType expected) + ) + ) + + +toShaderRecord : Dict String Name.Name Shader.Type -> Type -> Type +toShaderRecord types baseRecType = + if Dict.isEmpty types then + baseRecType + + else + RecordN (Dict.map (\_ -> glToType) types) baseRecType + + +glToType : Shader.Type -> Type +glToType glType = + case glType of + Shader.V2 -> + Type.vec2 + + Shader.V3 -> + Type.vec3 + + Shader.V4 -> + Type.vec4 + + Shader.M4 -> + Type.mat4 + + Shader.Int -> + Type.int + + Shader.Float -> + Type.float + + Shader.Texture -> + Type.texture + + Shader.Bool -> + Type.bool + + + +-- CONSTRAIN DESTRUCTURES + + +constrainDestruct : RTV -> A.Region -> Can.Pattern -> Can.Expr -> Constraint -> IO Constraint +constrainDestruct rtv region pattern expr bodyCon = + Type.mkFlexVar + |> IO.bind + (\patternVar -> + let + patternType : Type + patternType = + VarN patternVar + in + Pattern.add pattern (PNoExpectation patternType) Pattern.emptyState + |> IO.bind + (\(Pattern.State headers pvars revCons) -> + constrain rtv expr (FromContext region Destructure patternType) + |> IO.fmap + (\exprCon -> + CLet [] (patternVar :: pvars) headers (CAnd (List.reverse (exprCon :: revCons))) bodyCon + ) + ) + ) + + + +-- CONSTRAIN DEF + + +constrainDef : RTV -> Can.Def -> Constraint -> IO Constraint +constrainDef rtv def bodyCon = + case def of + Can.Def (A.At region name) args expr -> + constrainArgs args + |> IO.bind + (\(Args vars tipe resultType (Pattern.State headers pvars revCons)) -> + constrain rtv expr (NoExpectation resultType) + |> IO.fmap + (\exprCon -> + CLet [] + vars + (Dict.singleton identity name (A.At region tipe)) + (CLet [] + pvars + headers + (CAnd (List.reverse revCons)) + exprCon + ) + bodyCon + ) + ) + + Can.TypedDef (A.At region name) freeVars typedArgs expr srcResultType -> + let + newNames : Dict String Name () + newNames = + Dict.diff freeVars rtv + in + IO.traverseMapWithKey identity compare (\n _ -> Type.nameToRigid n) newNames + |> IO.bind + (\newRigids -> + let + newRtv : Dict String Name Type + newRtv = + Dict.union rtv (Dict.map (\_ -> VarN) newRigids) + in + constrainTypedArgs newRtv name typedArgs srcResultType + |> IO.bind + (\(TypedArgs tipe resultType (Pattern.State headers pvars revCons)) -> + let + expected : Expected Type + expected = + FromAnnotation name (List.length typedArgs) TypedBody resultType + in + constrain newRtv expr expected + |> IO.fmap + (\exprCon -> + CLet (Dict.values compare newRigids) + [] + (Dict.singleton identity name (A.At region tipe)) + (CLet [] + pvars + headers + (CAnd (List.reverse revCons)) + exprCon + ) + bodyCon + ) + ) + ) + + + +-- CONSTRAIN RECURSIVE DEFS + + +type Info + = Info (List IO.Variable) (List Constraint) (Dict String Name (A.Located Type)) + + +emptyInfo : Info +emptyInfo = + Info [] [] Dict.empty + + +constrainRecursiveDefs : RTV -> List Can.Def -> Constraint -> IO Constraint +constrainRecursiveDefs rtv defs bodyCon = + recDefsHelp rtv defs bodyCon emptyInfo emptyInfo + + +recDefsHelp : RTV -> List Can.Def -> Constraint -> Info -> Info -> IO Constraint +recDefsHelp rtv defs bodyCon rigidInfo flexInfo = + case defs of + [] -> + let + (Info rigidVars rigidCons rigidHeaders) = + rigidInfo + + (Info flexVars flexCons flexHeaders) = + flexInfo + in + IO.pure <| + CLet rigidVars [] rigidHeaders CTrue <| + CLet [] flexVars flexHeaders (CLet [] [] flexHeaders CTrue (CAnd flexCons)) <| + CAnd [ CAnd rigidCons, bodyCon ] + + def :: otherDefs -> + case def of + Can.Def (A.At region name) args expr -> + let + (Info flexVars flexCons flexHeaders) = + flexInfo + in + argsHelp args (Pattern.State Dict.empty flexVars []) + |> IO.bind + (\(Args newFlexVars tipe resultType (Pattern.State headers pvars revCons)) -> + constrain rtv expr (NoExpectation resultType) + |> IO.bind + (\exprCon -> + let + defCon : Constraint + defCon = + CLet [] + pvars + headers + (CAnd (List.reverse revCons)) + exprCon + in + recDefsHelp rtv otherDefs bodyCon rigidInfo <| + Info newFlexVars + (defCon :: flexCons) + (Dict.insert identity name (A.At region tipe) flexHeaders) + ) + ) + + Can.TypedDef (A.At region name) freeVars typedArgs expr srcResultType -> + let + newNames : Dict String Name () + newNames = + Dict.diff freeVars rtv + in + IO.traverseMapWithKey identity compare (\n _ -> Type.nameToRigid n) newNames + |> IO.bind + (\newRigids -> + let + newRtv : Dict String Name Type + newRtv = + Dict.union rtv (Dict.map (\_ -> VarN) newRigids) + in + constrainTypedArgs newRtv name typedArgs srcResultType + |> IO.bind + (\(TypedArgs tipe resultType (Pattern.State headers pvars revCons)) -> + constrain newRtv expr (FromAnnotation name (List.length typedArgs) TypedBody resultType) + |> IO.bind + (\exprCon -> + let + defCon : Constraint + defCon = + CLet [] + pvars + headers + (CAnd (List.reverse revCons)) + exprCon + + (Info rigidVars rigidCons rigidHeaders) = + rigidInfo + in + recDefsHelp rtv + otherDefs + bodyCon + (Info + (Dict.foldr compare (\_ -> (::)) rigidVars newRigids) + (CLet (Dict.values compare newRigids) [] Dict.empty defCon CTrue :: rigidCons) + (Dict.insert identity name (A.At region tipe) rigidHeaders) + ) + flexInfo + ) + ) + ) + + + +-- CONSTRAIN ARGS + + +type Args + = Args (List IO.Variable) Type Type Pattern.State + + +constrainArgs : List Can.Pattern -> IO Args +constrainArgs args = + argsHelp args Pattern.emptyState + + +argsHelp : List Can.Pattern -> Pattern.State -> IO Args +argsHelp args state = + case args of + [] -> + Type.mkFlexVar + |> IO.fmap + (\resultVar -> + let + resultType : Type + resultType = + VarN resultVar + in + Args [ resultVar ] resultType resultType state + ) + + pattern :: otherArgs -> + Type.mkFlexVar + |> IO.bind + (\argVar -> + let + argType : Type + argType = + VarN argVar + in + Pattern.add pattern (PNoExpectation argType) state + |> IO.bind (argsHelp otherArgs) + |> IO.fmap + (\(Args vars tipe result newState) -> + Args (argVar :: vars) (FunN argType tipe) result newState + ) + ) + + + +-- CONSTRAIN TYPED ARGS + + +type TypedArgs + = TypedArgs Type Type Pattern.State + + +constrainTypedArgs : Dict String Name.Name Type -> Name.Name -> List ( Can.Pattern, Can.Type ) -> Can.Type -> IO TypedArgs +constrainTypedArgs rtv name args srcResultType = + typedArgsHelp rtv name Index.first args srcResultType Pattern.emptyState + + +typedArgsHelp : Dict String Name.Name Type -> Name.Name -> Index.ZeroBased -> List ( Can.Pattern, Can.Type ) -> Can.Type -> Pattern.State -> IO TypedArgs +typedArgsHelp rtv name index args srcResultType state = + case args of + [] -> + Instantiate.fromSrcType rtv srcResultType + |> IO.fmap + (\resultType -> + TypedArgs resultType resultType state + ) + + ( (A.At region _) as pattern, srcType ) :: otherArgs -> + Instantiate.fromSrcType rtv srcType + |> IO.bind + (\argType -> + let + expected : PExpected Type + expected = + PFromContext region (PTypedArg name index) argType + in + Pattern.add pattern expected state + |> IO.bind (typedArgsHelp rtv name (Index.next index) otherArgs srcResultType) + |> IO.fmap + (\(TypedArgs tipe resultType newState) -> + TypedArgs (FunN argType tipe) resultType newState + ) + ) diff --git a/src/Compiler/Type/Constrain/Module.elm b/src/Compiler/Type/Constrain/Module.elm new file mode 100644 index 0000000000..179e34fea9 --- /dev/null +++ b/src/Compiler/Type/Constrain/Module.elm @@ -0,0 +1,296 @@ +module Compiler.Type.Constrain.Module exposing (constrain) + +import Compiler.AST.Canonical as Can +import Compiler.Data.Name as Name exposing (Name) +import Compiler.Elm.ModuleName as ModuleName +import Compiler.Reporting.Annotation as A +import Compiler.Reporting.Error.Type as E +import Compiler.Type.Constrain.Expression as Expr +import Compiler.Type.Instantiate as Instantiate +import Compiler.Type.Type as Type exposing (Constraint(..), Type(..), mkFlexVar, nameToRigid) +import Data.Map as Dict exposing (Dict) +import System.TypeCheck.IO as IO exposing (IO) + + + +-- CONSTRAIN + + +constrain : Can.Module -> IO Constraint +constrain (Can.Module home _ _ decls _ _ _ effects) = + case effects of + Can.NoEffects -> + constrainDecls decls CSaveTheEnvironment + + Can.Ports ports -> + Dict.foldr compare letPort (constrainDecls decls CSaveTheEnvironment) ports + + Can.Manager r0 r1 r2 manager -> + case manager of + Can.Cmd cmdName -> + constrainEffects home r0 r1 r2 manager + |> IO.bind (constrainDecls decls) + |> IO.bind (letCmd home cmdName) + + Can.Sub subName -> + constrainEffects home r0 r1 r2 manager + |> IO.bind (constrainDecls decls) + |> IO.bind (letSub home subName) + + Can.Fx cmdName subName -> + constrainEffects home r0 r1 r2 manager + |> IO.bind (constrainDecls decls) + |> IO.bind (letSub home subName) + |> IO.bind (letCmd home cmdName) + + + +-- CONSTRAIN DECLARATIONS + + +constrainDecls : Can.Decls -> Constraint -> IO Constraint +constrainDecls decls finalConstraint = + constrainDeclsHelp decls finalConstraint identity + + +constrainDeclsHelp : Can.Decls -> Constraint -> (IO Constraint -> IO Constraint) -> IO Constraint +constrainDeclsHelp decls finalConstraint cont = + case decls of + Can.Declare def otherDecls -> + constrainDeclsHelp otherDecls finalConstraint (IO.bind (Expr.constrainDef Dict.empty def) >> cont) + + Can.DeclareRec def defs otherDecls -> + constrainDeclsHelp otherDecls finalConstraint (IO.bind (Expr.constrainRecursiveDefs Dict.empty (def :: defs)) >> cont) + + Can.SaveTheEnvironment -> + cont (IO.pure finalConstraint) + + + +-- PORT HELPERS + + +letPort : Name -> Can.Port -> IO Constraint -> IO Constraint +letPort name port_ makeConstraint = + case port_ of + Can.Incoming { freeVars, func } -> + IO.traverseMapWithKey identity compare (\k _ -> nameToRigid k) freeVars + |> IO.bind + (\vars -> + Instantiate.fromSrcType (Dict.map (\_ v -> VarN v) vars) func + |> IO.bind + (\tipe -> + let + header : Dict String Name (A.Located Type) + header = + Dict.singleton identity name (A.At A.zero tipe) + in + IO.fmap (CLet (Dict.values compare vars) [] header CTrue) makeConstraint + ) + ) + + Can.Outgoing { freeVars, func } -> + IO.traverseMapWithKey identity compare (\k _ -> nameToRigid k) freeVars + |> IO.bind + (\vars -> + Instantiate.fromSrcType (Dict.map (\_ v -> VarN v) vars) func + |> IO.bind + (\tipe -> + let + header : Dict String Name (A.Located Type) + header = + Dict.singleton identity name (A.At A.zero tipe) + in + IO.fmap (CLet (Dict.values compare vars) [] header CTrue) makeConstraint + ) + ) + + + +-- EFFECT MANAGER HELPERS + + +letCmd : IO.Canonical -> Name -> Constraint -> IO Constraint +letCmd home tipe constraint = + mkFlexVar + |> IO.fmap + (\msgVar -> + let + msg : Type + msg = + VarN msgVar + + cmdType : Type + cmdType = + FunN (AppN home tipe [ msg ]) (AppN ModuleName.cmd Name.cmd [ msg ]) + + header : Dict String Name (A.Located Type) + header = + Dict.singleton identity "command" (A.At A.zero cmdType) + in + CLet [ msgVar ] [] header CTrue constraint + ) + + +letSub : IO.Canonical -> Name -> Constraint -> IO Constraint +letSub home tipe constraint = + mkFlexVar + |> IO.fmap + (\msgVar -> + let + msg : Type + msg = + VarN msgVar + + subType : Type + subType = + FunN (AppN home tipe [ msg ]) (AppN ModuleName.sub Name.sub [ msg ]) + + header : Dict String Name (A.Located Type) + header = + Dict.singleton identity "subscription" (A.At A.zero subType) + in + CLet [ msgVar ] [] header CTrue constraint + ) + + +constrainEffects : IO.Canonical -> A.Region -> A.Region -> A.Region -> Can.Manager -> IO Constraint +constrainEffects home r0 r1 r2 manager = + mkFlexVar + |> IO.bind + (\s0 -> + mkFlexVar + |> IO.bind + (\s1 -> + mkFlexVar + |> IO.bind + (\s2 -> + mkFlexVar + |> IO.bind + (\m1 -> + mkFlexVar + |> IO.bind + (\m2 -> + mkFlexVar + |> IO.bind + (\sm1 -> + mkFlexVar + |> IO.bind + (\sm2 -> + let + state0 : Type + state0 = + VarN s0 + + state1 : Type + state1 = + VarN s1 + + state2 : Type + state2 = + VarN s2 + + msg1 : Type + msg1 = + VarN m1 + + msg2 : Type + msg2 = + VarN m2 + + self1 : Type + self1 = + VarN sm1 + + self2 : Type + self2 = + VarN sm2 + + onSelfMsg : Type + onSelfMsg = + Type.funType (router msg2 self2) (Type.funType self2 (Type.funType state2 (task state2))) + + onEffects : Type + onEffects = + case manager of + Can.Cmd cmd -> + Type.funType (router msg1 self1) (Type.funType (effectList home cmd msg1) (Type.funType state1 (task state1))) + + Can.Sub sub -> + Type.funType (router msg1 self1) (Type.funType (effectList home sub msg1) (Type.funType state1 (task state1))) + + Can.Fx cmd sub -> + Type.funType (router msg1 self1) (Type.funType (effectList home cmd msg1) (Type.funType (effectList home sub msg1) (Type.funType state1 (task state1)))) + + effectCons : Constraint + effectCons = + CAnd + [ CLocal r0 "init" (E.NoExpectation (task state0)) + , CLocal r1 "onEffects" (E.NoExpectation onEffects) + , CLocal r2 "onSelfMsg" (E.NoExpectation onSelfMsg) + , CEqual r1 E.Effects state0 (E.NoExpectation state1) + , CEqual r2 E.Effects state0 (E.NoExpectation state2) + , CEqual r2 E.Effects self1 (E.NoExpectation self2) + ] + in + IO.fmap (CLet [] [ s0, s1, s2, m1, m2, sm1, sm2 ] Dict.empty effectCons) + (case manager of + Can.Cmd cmd -> + checkMap "cmdMap" home cmd CSaveTheEnvironment + + Can.Sub sub -> + checkMap "subMap" home sub CSaveTheEnvironment + + Can.Fx cmd sub -> + IO.bind (checkMap "cmdMap" home cmd) + (checkMap "subMap" home sub CSaveTheEnvironment) + ) + ) + ) + ) + ) + ) + ) + ) + + +effectList : IO.Canonical -> Name -> Type -> Type +effectList home name msg = + AppN ModuleName.list Name.list [ AppN home name [ msg ] ] + + +task : Type -> Type +task answer = + AppN ModuleName.platform Name.task [ Type.never, answer ] + + +router : Type -> Type -> Type +router msg self = + AppN ModuleName.platform Name.router [ msg, self ] + + +checkMap : Name -> IO.Canonical -> Name -> Constraint -> IO Constraint +checkMap name home tipe constraint = + mkFlexVar + |> IO.bind + (\a -> + mkFlexVar + |> IO.fmap + (\b -> + let + mapType : Type + mapType = + toMapType home tipe (VarN a) (VarN b) + + mapCon : Constraint + mapCon = + CLocal A.zero name (E.NoExpectation mapType) + in + CLet [ a, b ] [] Dict.empty mapCon constraint + ) + ) + + +toMapType : IO.Canonical -> Name -> Type -> Type -> Type +toMapType home tipe a b = + Type.funType (Type.funType a b) (Type.funType (AppN home tipe [ a ]) (AppN home tipe [ b ])) diff --git a/src/Compiler/Type/Constrain/Pattern.elm b/src/Compiler/Type/Constrain/Pattern.elm new file mode 100644 index 0000000000..0b983f33a5 --- /dev/null +++ b/src/Compiler/Type/Constrain/Pattern.elm @@ -0,0 +1,357 @@ +module Compiler.Type.Constrain.Pattern exposing + ( Header + , State(..) + , add + , emptyState + ) + +import Compiler.AST.Canonical as Can +import Compiler.Data.Index as Index +import Compiler.Data.Name as Name +import Compiler.Elm.ModuleName as ModuleName +import Compiler.Reporting.Annotation as A +import Compiler.Reporting.Error.Type as E +import Compiler.Type.Instantiate as Instantiate +import Compiler.Type.Type as Type exposing (Type) +import Data.Map as Dict exposing (Dict) +import System.TypeCheck.IO as IO exposing (IO) + + + +-- ACTUALLY ADD CONSTRAINTS +-- The constraints are stored in reverse order so that adding a new +-- constraint is O(1) and we can reverse it at some later time. + + +type State + = State Header (List IO.Variable) (List Type.Constraint) + + +type alias Header = + Dict String Name.Name (A.Located Type) + + +add : Can.Pattern -> E.PExpected Type -> State -> IO State +add (A.At region pattern) expectation state = + case pattern of + Can.PAnything -> + IO.pure state + + Can.PVar name -> + IO.pure (addToHeaders region name expectation state) + + Can.PAlias realPattern name -> + add realPattern expectation (addToHeaders region name expectation state) + + Can.PUnit -> + let + (State headers vars revCons) = + state + + unitCon : Type.Constraint + unitCon = + Type.CPattern region E.PUnit Type.UnitN expectation + in + IO.pure (State headers vars (unitCon :: revCons)) + + Can.PTuple a b cs -> + addTuple region a b cs expectation state + + Can.PCtor { home, type_, union, name, args } -> + let + (Can.Union typeVars _ _ _) = + union + in + addCtor region home type_ typeVars name args expectation state + + Can.PList patterns -> + Type.mkFlexVar + |> IO.bind + (\entryVar -> + let + entryType : Type + entryType = + Type.VarN entryVar + + listType : Type + listType = + Type.AppN ModuleName.list Name.list [ entryType ] + in + IO.foldM (addEntry region entryType) state (Index.indexedMap Tuple.pair patterns) + |> IO.fmap + (\(State headers vars revCons) -> + let + listCon : Type.Constraint + listCon = + Type.CPattern region E.PList listType expectation + in + State headers (entryVar :: vars) (listCon :: revCons) + ) + ) + + Can.PCons headPattern tailPattern -> + Type.mkFlexVar + |> IO.bind + (\entryVar -> + let + entryType : Type + entryType = + Type.VarN entryVar + + listType : Type + listType = + Type.AppN ModuleName.list Name.list [ entryType ] + + headExpectation : E.PExpected Type + headExpectation = + E.PNoExpectation entryType + + tailExpectation : E.PExpected Type + tailExpectation = + E.PFromContext region E.PTail listType + in + add tailPattern tailExpectation state + |> IO.bind (add headPattern headExpectation) + |> IO.fmap + (\(State headers vars revCons) -> + let + listCon : Type.Constraint + listCon = + Type.CPattern region E.PList listType expectation + in + State headers (entryVar :: vars) (listCon :: revCons) + ) + ) + + Can.PRecord fields -> + Type.mkFlexVar + |> IO.bind + (\extVar -> + let + extType : Type + extType = + Type.VarN extVar + in + IO.traverseList (\field -> IO.fmap (Tuple.pair field) Type.mkFlexVar) fields + |> IO.fmap + (\fieldVars -> + let + fieldTypes : Dict String Name.Name Type + fieldTypes = + Dict.fromList identity (List.map (Tuple.mapSecond Type.VarN) fieldVars) + + recordType : Type + recordType = + Type.RecordN fieldTypes extType + + (State headers vars revCons) = + state + + recordCon : Type.Constraint + recordCon = + Type.CPattern region E.PRecord recordType expectation + in + State + (Dict.union headers (Dict.map (\_ v -> A.At region v) fieldTypes)) + (List.map Tuple.second fieldVars ++ extVar :: vars) + (recordCon :: revCons) + ) + ) + + Can.PInt _ -> + let + (State headers vars revCons) = + state + + intCon : Type.Constraint + intCon = + Type.CPattern region E.PInt Type.int expectation + in + IO.pure (State headers vars (intCon :: revCons)) + + Can.PStr _ _ -> + let + (State headers vars revCons) = + state + + strCon : Type.Constraint + strCon = + Type.CPattern region E.PStr Type.string expectation + in + IO.pure (State headers vars (strCon :: revCons)) + + Can.PChr _ -> + let + (State headers vars revCons) = + state + + chrCon : Type.Constraint + chrCon = + Type.CPattern region E.PChr Type.char expectation + in + IO.pure (State headers vars (chrCon :: revCons)) + + Can.PBool _ _ -> + let + (State headers vars revCons) = + state + + boolCon : Type.Constraint + boolCon = + Type.CPattern region E.PBool Type.bool expectation + in + IO.pure (State headers vars (boolCon :: revCons)) + + + +-- STATE HELPERS + + +emptyState : State +emptyState = + State Dict.empty [] [] + + +addToHeaders : A.Region -> Name.Name -> E.PExpected Type -> State -> State +addToHeaders region name expectation (State headers vars revCons) = + let + tipe : Type + tipe = + getType expectation + + newHeaders : Dict String Name.Name (A.Located Type) + newHeaders = + Dict.insert identity name (A.At region tipe) headers + in + State newHeaders vars revCons + + +getType : E.PExpected Type -> Type +getType expectation = + case expectation of + E.PNoExpectation tipe -> + tipe + + E.PFromContext _ _ tipe -> + tipe + + + +-- CONSTRAIN LIST + + +addEntry : A.Region -> Type -> State -> ( Index.ZeroBased, Can.Pattern ) -> IO State +addEntry listRegion tipe state ( index, pattern ) = + let + expectation : E.PExpected Type + expectation = + E.PFromContext listRegion (E.PListEntry index) tipe + in + add pattern expectation state + + + +-- CONSTRAIN TUPLE + + +addTuple : A.Region -> Can.Pattern -> Can.Pattern -> List Can.Pattern -> E.PExpected Type -> State -> IO State +addTuple region a b cs expectation state = + Type.mkFlexVar + |> IO.bind + (\aVar -> + Type.mkFlexVar + |> IO.bind + (\bVar -> + let + aType : Type + aType = + Type.VarN aVar + + bType : Type + bType = + Type.VarN bVar + in + simpleAdd a aType state + |> IO.bind (simpleAdd b bType) + |> IO.bind + (\updatedState -> + IO.foldM + (\( cVars, s ) c -> + Type.mkFlexVar + |> IO.bind + (\cVar -> + simpleAdd c (Type.VarN cVar) s + |> IO.fmap (Tuple.pair (cVar :: cVars)) + ) + ) + ( [], updatedState ) + cs + |> IO.fmap + (\( cVars, State headers vars revCons ) -> + let + tupleCon : Type.Constraint + tupleCon = + Type.CPattern region E.PTuple (Type.TupleN aType bType (List.map Type.VarN cVars)) expectation + in + State headers (aVar :: bVar :: cVars ++ vars) (tupleCon :: revCons) + ) + ) + ) + ) + + +simpleAdd : Can.Pattern -> Type -> State -> IO State +simpleAdd pattern patternType state = + add pattern (E.PNoExpectation patternType) state + + + +-- CONSTRAIN CONSTRUCTORS + + +addCtor : A.Region -> IO.Canonical -> Name.Name -> List Name.Name -> Name.Name -> List Can.PatternCtorArg -> E.PExpected Type -> State -> IO State +addCtor region home typeName typeVarNames ctorName args expectation state = + IO.traverseList (\var -> IO.fmap (Tuple.pair var) (Type.nameToFlex var)) typeVarNames + |> IO.bind + (\varPairs -> + let + typePairs : List ( Name.Name, Type ) + typePairs = + List.map (Tuple.mapSecond Type.VarN) varPairs + + freeVarDict : Dict String Name.Name Type + freeVarDict = + Dict.fromList identity typePairs + in + IO.foldM (addCtorArg region ctorName freeVarDict) state args + |> IO.bind + (\(State headers vars revCons) -> + let + ctorType : Type + ctorType = + Type.AppN home typeName (List.map Tuple.second typePairs) + + ctorCon : Type.Constraint + ctorCon = + Type.CPattern region (E.PCtor ctorName) ctorType expectation + in + IO.pure <| + State headers + (List.map Tuple.second varPairs ++ vars) + (ctorCon :: revCons) + ) + ) + + +addCtorArg : A.Region -> Name.Name -> Dict String Name.Name Type -> State -> Can.PatternCtorArg -> IO State +addCtorArg region ctorName freeVarDict state (Can.PatternCtorArg index srcType pattern) = + Instantiate.fromSrcType freeVarDict srcType + |> IO.bind + (\tipe -> + let + expectation : E.PExpected Type + expectation = + E.PFromContext region (E.PCtorArg ctorName index) tipe + in + add pattern expectation state + ) diff --git a/src/Compiler/Type/Error.elm b/src/Compiler/Type/Error.elm new file mode 100644 index 0000000000..556425426d --- /dev/null +++ b/src/Compiler/Type/Error.elm @@ -0,0 +1,1065 @@ +module Compiler.Type.Error exposing + ( Direction(..) + , Extension(..) + , Problem(..) + , Super(..) + , Type(..) + , isChar + , isFloat + , isInt + , isList + , isString + , iteratedDealias + , toComparison + , toDoc + , typeDecoder + , typeEncoder + ) + +import Compiler.Data.Bag as Bag +import Compiler.Data.Name as Name exposing (Name) +import Compiler.Elm.ModuleName as ModuleName +import Compiler.Reporting.Doc as D +import Compiler.Reporting.Render.Type as RT +import Compiler.Reporting.Render.Type.Localizer as L +import Data.Map as Dict exposing (Dict) +import Prelude +import System.TypeCheck.IO as IO +import Utils.Bytes.Decode as BD +import Utils.Bytes.Encode as BE + + + +-- ERROR TYPES + + +type Type + = Lambda Type Type (List Type) + | Infinite + | Error + | FlexVar Name + | FlexSuper Super Name + | RigidVar Name + | RigidSuper Super Name + | Type IO.Canonical Name (List Type) + | Record (Dict String Name Type) Extension + | Unit + | Tuple Type Type (List Type) + | Alias IO.Canonical Name (List ( Name, Type )) Type + + +type Super + = Number + | Comparable + | Appendable + | CompAppend + + +type Extension + = Closed + | FlexOpen Name + | RigidOpen Name + + +iteratedDealias : Type -> Type +iteratedDealias tipe = + case tipe of + Alias _ _ _ real -> + iteratedDealias real + + _ -> + tipe + + + +-- TO DOC + + +toDoc : L.Localizer -> RT.Context -> Type -> D.Doc +toDoc localizer ctx tipe = + case tipe of + Lambda a b cs -> + RT.lambda ctx + (toDoc localizer RT.Func a) + (toDoc localizer RT.Func b) + (List.map (toDoc localizer RT.Func) cs) + + Infinite -> + D.fromChars "∞" + + Error -> + D.fromChars "?" + + FlexVar name -> + D.fromName name + + FlexSuper _ name -> + D.fromName name + + RigidVar name -> + D.fromName name + + RigidSuper _ name -> + D.fromName name + + Type home name args -> + RT.apply ctx + (L.toDoc localizer home name) + (List.map (toDoc localizer RT.App) args) + + Record fields ext -> + RT.record (fieldsToDocs localizer fields) (extToDoc ext) + + Unit -> + D.fromChars "()" + + Tuple a b cs -> + RT.tuple + (toDoc localizer RT.None a) + (toDoc localizer RT.None b) + (List.map (toDoc localizer RT.None) cs) + + Alias home name args _ -> + aliasToDoc localizer ctx home name args + + +aliasToDoc : L.Localizer -> RT.Context -> IO.Canonical -> Name -> List ( Name, Type ) -> D.Doc +aliasToDoc localizer ctx home name args = + RT.apply ctx + (L.toDoc localizer home name) + (List.map (toDoc localizer RT.App << Tuple.second) args) + + +fieldsToDocs : L.Localizer -> Dict String Name Type -> List ( D.Doc, D.Doc ) +fieldsToDocs localizer fields = + Dict.foldr compare (addField localizer) [] fields + + +addField : L.Localizer -> Name -> Type -> List ( D.Doc, D.Doc ) -> List ( D.Doc, D.Doc ) +addField localizer fieldName fieldType docs = + let + f : D.Doc + f = + D.fromName fieldName + + t : D.Doc + t = + toDoc localizer RT.None fieldType + in + ( f, t ) :: docs + + +extToDoc : Extension -> Maybe D.Doc +extToDoc ext = + case ext of + Closed -> + Nothing + + FlexOpen x -> + Just (D.fromName x) + + RigidOpen x -> + Just (D.fromName x) + + + +-- DIFF + + +type Diff a + = Diff a a Status + + +type Status + = Similar + | Different (Bag.Bag Problem) + + +type Problem + = IntFloat + | StringFromInt + | StringFromFloat + | StringToInt + | StringToFloat + | AnythingToBool + | AnythingFromMaybe + | ArityMismatch Int Int + | BadFlexSuper Direction Super Type + | BadRigidVar Name Type + | BadRigidSuper Super Name Type + | FieldTypo Name (List Name) + | FieldsMissing (List Name) + + +type Direction + = Have + | Need + + +fmapDiff : (a -> b) -> Diff a -> Diff b +fmapDiff func (Diff a b status) = + Diff (func a) (func b) status + + +pureDiff : a -> Diff a +pureDiff a = + Diff a a Similar + + +applyDiff : Diff a -> Diff (a -> b) -> Diff b +applyDiff (Diff aArg bArg status2) (Diff aFunc bFunc status1) = + Diff (aFunc aArg) (bFunc bArg) (merge status1 status2) + + +liftA2 : (a -> b -> c) -> Diff a -> Diff b -> Diff c +liftA2 f x y = + applyDiff y (fmapDiff f x) + + +merge : Status -> Status -> Status +merge status1 status2 = + case status1 of + Similar -> + status2 + + Different problems1 -> + case status2 of + Similar -> + status1 + + Different problems2 -> + Different (Bag.append problems1 problems2) + + + +-- COMPARISON + + +toComparison : L.Localizer -> Type -> Type -> ( D.Doc, D.Doc, List Problem ) +toComparison localizer tipe1 tipe2 = + case toDiff localizer RT.None tipe1 tipe2 of + Diff doc1 doc2 Similar -> + ( doc1, doc2, [] ) + + Diff doc1 doc2 (Different problems) -> + ( doc1, doc2, Bag.toList problems ) + + +toDiff : L.Localizer -> RT.Context -> Type -> Type -> Diff D.Doc +toDiff localizer ctx tipe1 tipe2 = + case ( tipe1, tipe2 ) of + ( Unit, Unit ) -> + same localizer ctx tipe1 + + ( Error, Error ) -> + same localizer ctx tipe1 + + ( Infinite, Infinite ) -> + same localizer ctx tipe1 + + ( FlexVar x, FlexVar y ) -> + if x == y then + same localizer ctx tipe1 + + else + toDiffOtherwise localizer ctx ( tipe1, tipe2 ) + + ( FlexSuper _ x, FlexSuper _ y ) -> + if x == y then + same localizer ctx tipe1 + + else + toDiffOtherwise localizer ctx ( tipe1, tipe2 ) + + ( RigidVar x, RigidVar y ) -> + if x == y then + same localizer ctx tipe1 + + else + toDiffOtherwise localizer ctx ( tipe1, tipe2 ) + + ( RigidSuper _ x, RigidSuper _ y ) -> + if x == y then + same localizer ctx tipe1 + + else + toDiffOtherwise localizer ctx ( tipe1, tipe2 ) + + ( FlexVar _, _ ) -> + similar localizer ctx tipe1 tipe2 + + ( _, FlexVar _ ) -> + similar localizer ctx tipe1 tipe2 + + ( FlexSuper s _, t ) -> + if isSuper s t then + similar localizer ctx tipe1 tipe2 + + else + toDiffOtherwise localizer ctx ( tipe1, tipe2 ) + + ( t, FlexSuper s _ ) -> + if isSuper s t then + similar localizer ctx tipe1 tipe2 + + else + toDiffOtherwise localizer ctx ( tipe1, tipe2 ) + + ( Lambda a b cs, Lambda x y zs ) -> + if List.length cs == List.length zs then + toDiff localizer RT.Func a x + |> fmapDiff (RT.lambda ctx) + |> applyDiff (toDiff localizer RT.Func b y) + |> applyDiff + (List.map2 (toDiff localizer RT.Func) cs zs + |> List.foldr (liftA2 (::)) (pureDiff []) + ) + + else + let + f : Type -> D.Doc + f = + toDoc localizer RT.Func + in + different + (D.dullyellow (RT.lambda ctx (f a) (f b) (List.map f cs))) + (D.dullyellow (RT.lambda ctx (f x) (f y) (List.map f zs))) + (Bag.one (ArityMismatch (2 + List.length cs) (2 + List.length zs))) + + ( Tuple a b cs, Tuple x y zs ) as pair -> + toDiffTuple localizer ctx pair ( a, b, cs ) ( x, y, zs ) (pureDiff []) + + ( Record fields1 ext1, Record fields2 ext2 ) -> + diffRecord localizer fields1 ext1 fields2 ext2 + + ( Type home1 name1 args1, Type home2 name2 args2 ) -> + if home1 == home2 && name1 == name2 then + List.map2 (toDiff localizer RT.App) args1 args2 + |> List.foldr (liftA2 (::)) (pureDiff []) + |> fmapDiff (RT.apply ctx (L.toDoc localizer home1 name1)) + + else if L.toChars localizer home1 name1 == L.toChars localizer home2 name2 then + -- start trying to find specific problems (this used to be down on the list) + different + (nameClashToDoc ctx localizer home1 name1 args1) + (nameClashToDoc ctx localizer home2 name2 args2) + Bag.empty + + else + toDiffOtherwise localizer ctx ( tipe1, tipe2 ) + + ( Alias home1 name1 args1 _, Alias home2 name2 args2 _ ) -> + if home1 == home2 && name1 == name2 then + List.map2 (toDiff localizer RT.App) (List.map Tuple.second args1) (List.map Tuple.second args2) + |> List.foldr (liftA2 (::)) (pureDiff []) + |> fmapDiff (RT.apply ctx (L.toDoc localizer home1 name1)) + + else + toDiffOtherwise localizer ctx ( tipe1, tipe2 ) + + -- start trying to find specific problems (moved first check above) + ( Type home name [ t1 ], t2 ) -> + if isMaybe home name && isSimilar (toDiff localizer ctx t1 t2) then + different + (RT.apply ctx (D.dullyellow (L.toDoc localizer home name)) [ toDoc localizer RT.App t1 ]) + (toDoc localizer ctx t2) + (Bag.one AnythingFromMaybe) + + else + toDiffOtherwise localizer ctx ( tipe1, tipe2 ) + + ( t1, Type home name [ t2 ] ) -> + if isList home name && isSimilar (toDiff localizer ctx t1 t2) then + different + (toDoc localizer ctx t1) + (RT.apply ctx (D.dullyellow (L.toDoc localizer home name)) [ toDoc localizer RT.App t2 ]) + Bag.empty + + else + toDiffOtherwise localizer ctx ( tipe1, tipe2 ) + + ( Alias home1 name1 args1 t1, t2 ) -> + case diffAliasedRecord localizer t1 t2 of + Just (Diff _ doc2 status) -> + Diff (D.dullyellow (aliasToDoc localizer ctx home1 name1 args1)) doc2 status + + Nothing -> + case tipe2 of + Type home2 name2 args2 -> + if L.toChars localizer home1 name1 == L.toChars localizer home2 name2 then + different + (nameClashToDoc ctx localizer home1 name1 (List.map Tuple.second args1)) + (nameClashToDoc ctx localizer home2 name2 args2) + Bag.empty + + else + different + (D.dullyellow (toDoc localizer ctx tipe1)) + (D.dullyellow (toDoc localizer ctx tipe2)) + Bag.empty + + _ -> + different + (D.dullyellow (toDoc localizer ctx tipe1)) + (D.dullyellow (toDoc localizer ctx tipe2)) + Bag.empty + + ( _, Alias home2 name2 args2 _ ) -> + case diffAliasedRecord localizer tipe1 tipe2 of + Just (Diff doc1 _ status) -> + Diff doc1 (D.dullyellow (aliasToDoc localizer ctx home2 name2 args2)) status + + Nothing -> + case tipe1 of + Type home1 name1 args1 -> + if L.toChars localizer home1 name1 == L.toChars localizer home2 name2 then + different + (nameClashToDoc ctx localizer home1 name1 args1) + (nameClashToDoc ctx localizer home2 name2 (List.map Tuple.second args2)) + Bag.empty + + else + different + (D.dullyellow (toDoc localizer ctx tipe1)) + (D.dullyellow (toDoc localizer ctx tipe2)) + Bag.empty + + _ -> + different + (D.dullyellow (toDoc localizer ctx tipe1)) + (D.dullyellow (toDoc localizer ctx tipe2)) + Bag.empty + + pair -> + toDiffOtherwise localizer ctx pair + + +toDiffTuple : L.Localizer -> RT.Context -> ( Type, Type ) -> ( Type, Type, List Type ) -> ( Type, Type, List Type ) -> Diff (List D.Doc) -> Diff D.Doc +toDiffTuple localizer ctx pair ( a, b, cs ) ( x, y, zs ) diffCs = + case ( cs, zs ) of + ( [], [] ) -> + toDiff localizer RT.None a x + |> fmapDiff RT.tuple + |> applyDiff (toDiff localizer RT.None b y) + |> applyDiff diffCs + + ( c :: restCs, z :: restZs ) -> + fmapDiff (::) (toDiff localizer RT.None c z) + |> applyDiff diffCs + |> toDiffTuple localizer ctx pair ( a, b, restCs ) ( x, y, restZs ) + + _ -> + toDiffOtherwise localizer ctx pair + + +toDiffOtherwise : L.Localizer -> RT.Context -> ( Type, Type ) -> Diff D.Doc +toDiffOtherwise localizer ctx (( tipe1, tipe2 ) as pair) = + let + doc1 : D.Doc + doc1 = + D.dullyellow (toDoc localizer ctx tipe1) + + doc2 : D.Doc + doc2 = + D.dullyellow (toDoc localizer ctx tipe2) + in + different doc1 doc2 <| + case pair of + ( RigidVar x, other ) -> + Bag.one <| BadRigidVar x other + + ( FlexSuper s _, other ) -> + Bag.one <| BadFlexSuper Have s other + + ( RigidSuper s x, other ) -> + Bag.one <| BadRigidSuper s x other + + ( other, RigidVar x ) -> + Bag.one <| BadRigidVar x other + + ( other, FlexSuper s _ ) -> + Bag.one <| BadFlexSuper Need s other + + ( other, RigidSuper s x ) -> + Bag.one <| BadRigidSuper s x other + + ( Type home1 name1 [], Type home2 name2 [] ) -> + if isInt home1 name1 && isFloat home2 name2 then + Bag.one <| IntFloat + + else if isFloat home1 name1 && isInt home2 name2 then + Bag.one <| IntFloat + + else if isInt home1 name1 && isString home2 name2 then + Bag.one <| StringFromInt + + else if isFloat home1 name1 && isString home2 name2 then + Bag.one <| StringFromFloat + + else if isString home1 name1 && isInt home2 name2 then + Bag.one <| StringToInt + + else if isString home1 name1 && isFloat home2 name2 then + Bag.one <| StringToFloat + + else if isBool home2 name2 then + Bag.one <| AnythingToBool + + else + Bag.empty + + _ -> + Bag.empty + + + +-- DIFF HELPERS + + +same : L.Localizer -> RT.Context -> Type -> Diff D.Doc +same localizer ctx tipe = + let + doc : D.Doc + doc = + toDoc localizer ctx tipe + in + Diff doc doc Similar + + +similar : L.Localizer -> RT.Context -> Type -> Type -> Diff D.Doc +similar localizer ctx t1 t2 = + Diff (toDoc localizer ctx t1) (toDoc localizer ctx t2) Similar + + +different : a -> a -> Bag.Bag Problem -> Diff a +different a b problems = + Diff a b (Different problems) + + +isSimilar : Diff a -> Bool +isSimilar (Diff _ _ status) = + case status of + Similar -> + True + + Different _ -> + False + + + +-- IS TYPE? + + +isBool : IO.Canonical -> Name -> Bool +isBool home name = + home == ModuleName.basics && name == Name.bool + + +isInt : IO.Canonical -> Name -> Bool +isInt home name = + home == ModuleName.basics && name == Name.int + + +isFloat : IO.Canonical -> Name -> Bool +isFloat home name = + home == ModuleName.basics && name == Name.float + + +isString : IO.Canonical -> Name -> Bool +isString home name = + home == ModuleName.string && name == Name.string + + +isChar : IO.Canonical -> Name -> Bool +isChar home name = + home == ModuleName.char && name == Name.char + + +isMaybe : IO.Canonical -> Name -> Bool +isMaybe home name = + home == ModuleName.maybe && name == Name.maybe + + +isList : IO.Canonical -> Name -> Bool +isList home name = + home == ModuleName.list && name == Name.list + + + +-- IS SUPER? + + +isSuper : Super -> Type -> Bool +isSuper super tipe = + case iteratedDealias tipe of + Type h n args -> + case super of + Number -> + isInt h n || isFloat h n + + Comparable -> + isInt h n || isFloat h n || isString h n || isChar h n || isList h n && isSuper super (Prelude.head args) + + Appendable -> + isString h n || isList h n + + CompAppend -> + isString h n || isList h n && isSuper Comparable (Prelude.head args) + + Tuple a b cs -> + case super of + Number -> + False + + Comparable -> + List.all (isSuper super) (a :: b :: cs) + + Appendable -> + False + + CompAppend -> + False + + _ -> + False + + + +-- NAME CLASH + + +nameClashToDoc : RT.Context -> L.Localizer -> IO.Canonical -> Name -> List Type -> D.Doc +nameClashToDoc ctx localizer (IO.Canonical _ home) name args = + RT.apply ctx + (D.yellow (D.fromName home) |> D.a (D.dullyellow (D.fromChars "." |> D.a (D.fromName name)))) + (List.map (toDoc localizer RT.App) args) + + + +-- DIFF ALIASED RECORD + + +diffAliasedRecord : L.Localizer -> Type -> Type -> Maybe (Diff D.Doc) +diffAliasedRecord localizer t1 t2 = + case ( iteratedDealias t1, iteratedDealias t2 ) of + ( Record fields1 ext1, Record fields2 ext2 ) -> + Just (diffRecord localizer fields1 ext1 fields2 ext2) + + _ -> + Nothing + + + +-- RECORD DIFFS + + +diffRecord : L.Localizer -> Dict String Name Type -> Extension -> Dict String Name Type -> Extension -> Diff D.Doc +diffRecord localizer fields1 ext1 fields2 ext2 = + let + toUnknownDocs : Name -> Type -> ( D.Doc, D.Doc ) + toUnknownDocs field tipe = + ( D.dullyellow (D.fromName field), toDoc localizer RT.None tipe ) + + toOverlapDocs : Name -> Type -> Type -> Diff ( D.Doc, D.Doc ) + toOverlapDocs field t1 t2 = + fmapDiff (Tuple.pair (D.fromName field)) <| toDiff localizer RT.None t1 t2 + + left : Dict String Name ( D.Doc, D.Doc ) + left = + Dict.map toUnknownDocs (Dict.diff fields1 fields2) + + right : Dict String Name ( D.Doc, D.Doc ) + right = + Dict.map toUnknownDocs (Dict.diff fields2 fields1) + + fieldsDiff : Diff (List ( D.Doc, D.Doc )) + fieldsDiff = + let + fieldsDiffDict : Diff (Dict String Name ( D.Doc, D.Doc )) + fieldsDiffDict = + let + both : Dict String Name (Diff ( D.Doc, D.Doc )) + both = + Dict.merge compare + (\_ _ acc -> acc) + (\field t1 t2 acc -> Dict.insert identity field (toOverlapDocs field t1 t2) acc) + (\_ _ acc -> acc) + fields1 + fields2 + Dict.empty + + sequenceA : Dict String Name (Diff ( D.Doc, D.Doc )) -> Diff (Dict String Name ( D.Doc, D.Doc )) + sequenceA = + Dict.foldr compare (\k x acc -> applyDiff acc (fmapDiff (Dict.insert identity k) x)) (pureDiff Dict.empty) + in + if Dict.isEmpty left && Dict.isEmpty right then + sequenceA both + + else + liftA2 Dict.union + (sequenceA both) + (Diff left right (Different Bag.empty)) + in + fmapDiff (Dict.values compare) fieldsDiffDict + + (Diff doc1 doc2 status) = + fieldsDiff + |> fmapDiff RT.record + |> applyDiff (extToDiff ext1 ext2) + in + Diff doc1 doc2 <| + merge status <| + case ( hasFixedFields ext1, hasFixedFields ext2 ) of + ( True, True ) -> + let + minView : Maybe ( Name, ( D.Doc, D.Doc ) ) + minView = + Dict.toList compare left + |> List.sortBy Tuple.first + |> List.head + in + case minView of + Just ( f, _ ) -> + Different (Bag.one (FieldTypo f (Dict.keys compare fields2))) + + Nothing -> + if Dict.isEmpty right then + Similar + + else + Different (Bag.one (FieldsMissing (Dict.keys compare right))) + + ( False, True ) -> + let + minView : Maybe ( Name, ( D.Doc, D.Doc ) ) + minView = + Dict.toList compare left + |> List.sortBy Tuple.first + |> List.head + in + case minView of + Just ( f, _ ) -> + Different (Bag.one (FieldTypo f (Dict.keys compare fields2))) + + Nothing -> + Similar + + ( True, False ) -> + let + minView : Maybe ( Name, ( D.Doc, D.Doc ) ) + minView = + Dict.toList compare right + |> List.sortBy Tuple.first + |> List.head + in + case minView of + Just ( f, _ ) -> + Different (Bag.one (FieldTypo f (Dict.keys compare fields1))) + + Nothing -> + Similar + + ( False, False ) -> + Similar + + +hasFixedFields : Extension -> Bool +hasFixedFields ext = + case ext of + Closed -> + True + + FlexOpen _ -> + False + + RigidOpen _ -> + True + + + +-- DIFF RECORD EXTENSION + + +extToDiff : Extension -> Extension -> Diff (Maybe D.Doc) +extToDiff ext1 ext2 = + let + status : Status + status = + extToStatus ext1 ext2 + + extDoc1 : Maybe D.Doc + extDoc1 = + extToDoc ext1 + + extDoc2 : Maybe D.Doc + extDoc2 = + extToDoc ext2 + in + case status of + Similar -> + Diff extDoc1 extDoc2 status + + Different _ -> + Diff (Maybe.map D.dullyellow extDoc1) (Maybe.map D.dullyellow extDoc2) status + + +extToStatus : Extension -> Extension -> Status +extToStatus ext1 ext2 = + case ext1 of + Closed -> + case ext2 of + Closed -> + Similar + + FlexOpen _ -> + Similar + + RigidOpen _ -> + Different Bag.empty + + FlexOpen _ -> + Similar + + RigidOpen x -> + case ext2 of + Closed -> + Different Bag.empty + + FlexOpen _ -> + Similar + + RigidOpen y -> + if x == y then + Similar + + else + Different (Bag.one (BadRigidVar x (RigidVar y))) + + + +-- ENCODERS and DECODERS + + +typeEncoder : Type -> BE.Encoder +typeEncoder type_ = + case type_ of + Lambda x y zs -> + BE.sequence + [ BE.unsignedInt8 0 + , typeEncoder x + , typeEncoder y + , BE.list typeEncoder zs + ] + + Infinite -> + BE.unsignedInt8 1 + + Error -> + BE.unsignedInt8 2 + + FlexVar name -> + BE.sequence + [ BE.unsignedInt8 3 + , BE.string name + ] + + FlexSuper s x -> + BE.sequence + [ BE.unsignedInt8 4 + , superEncoder s + , BE.string x + ] + + RigidVar name -> + BE.sequence + [ BE.unsignedInt8 5 + , BE.string name + ] + + RigidSuper s x -> + BE.sequence + [ BE.unsignedInt8 6 + , superEncoder s + , BE.string x + ] + + Type home name args -> + BE.sequence + [ BE.unsignedInt8 7 + , ModuleName.canonicalEncoder home + , BE.string name + , BE.list typeEncoder args + ] + + Record msgType decoder -> + BE.sequence + [ BE.unsignedInt8 8 + , BE.assocListDict compare BE.string typeEncoder msgType + , extensionEncoder decoder + ] + + Unit -> + BE.unsignedInt8 9 + + Tuple a b cs -> + BE.sequence + [ BE.unsignedInt8 10 + , typeEncoder a + , typeEncoder b + , BE.list typeEncoder cs + ] + + Alias home name args tipe -> + BE.sequence + [ BE.unsignedInt8 11 + , ModuleName.canonicalEncoder home + , BE.string name + , BE.list (BE.jsonPair BE.string typeEncoder) args + , typeEncoder tipe + ] + + +typeDecoder : BD.Decoder Type +typeDecoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.map3 Lambda + typeDecoder + typeDecoder + (BD.list typeDecoder) + + 1 -> + BD.succeed Infinite + + 2 -> + BD.succeed Error + + 3 -> + BD.map FlexVar BD.string + + 4 -> + BD.map2 FlexSuper + superDecoder + BD.string + + 5 -> + BD.map RigidVar BD.string + + 6 -> + BD.map2 RigidSuper + superDecoder + BD.string + + 7 -> + BD.map3 Type + ModuleName.canonicalDecoder + BD.string + (BD.list typeDecoder) + + 8 -> + BD.map2 Record + (BD.assocListDict identity BD.string typeDecoder) + extensionDecoder + + 9 -> + BD.succeed Unit + + 10 -> + BD.map3 Tuple + typeDecoder + typeDecoder + (BD.list typeDecoder) + + 11 -> + BD.map4 Alias + ModuleName.canonicalDecoder + BD.string + (BD.list (BD.jsonPair BD.string typeDecoder)) + typeDecoder + + _ -> + BD.fail + ) + + +superEncoder : Super -> BE.Encoder +superEncoder super = + BE.unsignedInt8 + (case super of + Number -> + 0 + + Comparable -> + 1 + + Appendable -> + 2 + + CompAppend -> + 3 + ) + + +superDecoder : BD.Decoder Super +superDecoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.succeed Number + + 1 -> + BD.succeed Comparable + + 2 -> + BD.succeed Appendable + + 3 -> + BD.succeed CompAppend + + _ -> + BD.fail + ) + + +extensionEncoder : Extension -> BE.Encoder +extensionEncoder extension = + case extension of + Closed -> + BE.unsignedInt8 0 + + FlexOpen x -> + BE.sequence + [ BE.unsignedInt8 1 + , BE.string x + ] + + RigidOpen x -> + BE.sequence + [ BE.unsignedInt8 2 + , BE.string x + ] + + +extensionDecoder : BD.Decoder Extension +extensionDecoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.succeed Closed + + 1 -> + BD.map FlexOpen BD.string + + 2 -> + BD.map RigidOpen BD.string + + _ -> + BD.fail + ) diff --git a/src/Compiler/Type/Instantiate.elm b/src/Compiler/Type/Instantiate.elm new file mode 100644 index 0000000000..ab9d8aa3ba --- /dev/null +++ b/src/Compiler/Type/Instantiate.elm @@ -0,0 +1,79 @@ +module Compiler.Type.Instantiate exposing + ( FreeVars + , fromSrcType + ) + +import Compiler.AST.Canonical as Can +import Compiler.Data.Name exposing (Name) +import Compiler.Type.Type exposing (Type(..)) +import Data.Map as Dict exposing (Dict) +import System.TypeCheck.IO as IO exposing (IO) +import Utils.Main as Utils + + + +-- FREE VARS + + +type alias FreeVars = + Dict String Name Type + + + +-- FROM SOURCE TYPE + + +fromSrcType : FreeVars -> Can.Type -> IO Type +fromSrcType freeVars sourceType = + case sourceType of + Can.TLambda arg result -> + IO.pure FunN + |> IO.apply (fromSrcType freeVars arg) + |> IO.apply (fromSrcType freeVars result) + + Can.TVar name -> + IO.pure (Utils.find identity name freeVars) + + Can.TType home name args -> + IO.fmap (AppN home name) + (IO.traverseList (fromSrcType freeVars) args) + + Can.TAlias home name args aliasedType -> + IO.traverseList (IO.traverseTuple (fromSrcType freeVars)) args + |> IO.bind + (\targs -> + IO.fmap (AliasN home name targs) + (case aliasedType of + Can.Filled realType -> + fromSrcType freeVars realType + + Can.Holey realType -> + fromSrcType (Dict.fromList identity targs) realType + ) + ) + + Can.TTuple a b maybeC -> + IO.pure TupleN + |> IO.apply (fromSrcType freeVars a) + |> IO.apply (fromSrcType freeVars b) + |> IO.apply (IO.traverseList (fromSrcType freeVars) maybeC) + + Can.TUnit -> + IO.pure UnitN + + Can.TRecord fields maybeExt -> + IO.pure RecordN + |> IO.apply (IO.traverseMap identity compare (fromSrcFieldType freeVars) fields) + |> IO.apply + (case maybeExt of + Nothing -> + IO.pure EmptyRecordN + + Just ext -> + IO.pure (Utils.find identity ext freeVars) + ) + + +fromSrcFieldType : Dict String Name Type -> Can.FieldType -> IO Type +fromSrcFieldType freeVars (Can.FieldType _ tipe) = + fromSrcType freeVars tipe diff --git a/src/Compiler/Type/Occurs.elm b/src/Compiler/Type/Occurs.elm new file mode 100644 index 0000000000..1d0843fb5d --- /dev/null +++ b/src/Compiler/Type/Occurs.elm @@ -0,0 +1,74 @@ +module Compiler.Type.Occurs exposing (occurs) + +import Compiler.Type.UnionFind as UF +import Data.Map as Dict +import System.TypeCheck.IO as IO exposing (IO) + + + +-- OCCURS + + +occurs : IO.Variable -> IO Bool +occurs var = + occursHelp [] var False + + +occursHelp : List IO.Variable -> IO.Variable -> Bool -> IO Bool +occursHelp seen var foundCycle = + if List.member var seen then + IO.pure True + + else + UF.get var + |> IO.bind + (\(IO.Descriptor content _ _ _) -> + case content of + IO.FlexVar _ -> + IO.pure foundCycle + + IO.FlexSuper _ _ -> + IO.pure foundCycle + + IO.RigidVar _ -> + IO.pure foundCycle + + IO.RigidSuper _ _ -> + IO.pure foundCycle + + IO.Structure term -> + let + newSeen : List IO.Variable + newSeen = + var :: seen + in + case term of + IO.App1 _ _ args -> + IO.foldrM (occursHelp newSeen) foundCycle args + + IO.Fun1 a b -> + IO.bind (occursHelp newSeen a) + (occursHelp newSeen b foundCycle) + + IO.EmptyRecord1 -> + IO.pure foundCycle + + IO.Record1 fields ext -> + IO.bind (occursHelp newSeen ext) <| + IO.foldrM (occursHelp newSeen) foundCycle (Dict.values compare fields) + + IO.Unit1 -> + IO.pure foundCycle + + IO.Tuple1 a b cs -> + IO.bind (occursHelp newSeen a) + (IO.bind (occursHelp newSeen b) + (IO.foldrM (occursHelp newSeen) foundCycle cs) + ) + + IO.Alias _ _ args _ -> + IO.foldrM (occursHelp (var :: seen)) foundCycle (List.map Tuple.second args) + + IO.Error -> + IO.pure foundCycle + ) diff --git a/src/Compiler/Type/Solve.elm b/src/Compiler/Type/Solve.elm new file mode 100644 index 0000000000..11e851e838 --- /dev/null +++ b/src/Compiler/Type/Solve.elm @@ -0,0 +1,1080 @@ +module Compiler.Type.Solve exposing (run) + +import Array exposing (Array) +import Compiler.AST.Canonical as Can +import Compiler.Data.Name as Name +import Compiler.Data.NonEmptyList as NE +import Compiler.Reporting.Annotation as A +import Compiler.Reporting.Doc as Doc +import Compiler.Reporting.Error.Type as Error +import Compiler.Reporting.Render.Type as RT +import Compiler.Reporting.Render.Type.Localizer as L +import Compiler.Type.Error as ET +import Compiler.Type.Occurs as Occurs +import Compiler.Type.Type as Type exposing (Constraint(..), Type, nextMark) +import Compiler.Type.Unify as Unify +import Compiler.Type.UnionFind as UF +import Data.IORef exposing (IORef) +import Data.Map as Dict exposing (Dict) +import Data.Vector as Vector +import Data.Vector.Mutable as MVector +import System.TypeCheck.IO as IO exposing (Content, Descriptor(..), IO, Mark, Variable) +import Utils.Crash exposing (crash) +import Utils.Main as Utils + + + +-- RUN SOLVER + + +run : Constraint -> IO (Result (NE.Nonempty Error.Error) (Dict String Name.Name Can.Annotation)) +run constraint = + MVector.replicate 8 [] + |> IO.bind + (\pools -> + solve Dict.empty Type.outermostRank pools emptyState constraint + |> IO.bind + (\(State env _ errors) -> + case errors of + [] -> + IO.traverseMap identity compare Type.toAnnotation env + |> IO.fmap Ok + + e :: es -> + IO.pure (Err (NE.Nonempty e es)) + ) + ) + + +emptyState : State +emptyState = + State Dict.empty (Type.nextMark Type.noMark) [] + + + +-- SOLVER + + +type alias Env = + Dict String Name.Name Variable + + +type alias Pools = + IORef (Array (Maybe (List Variable))) + + +type State + = State Env Mark (List Error.Error) + + +solve : Env -> Int -> Pools -> State -> Constraint -> IO State +solve env rank pools state constraint = + IO.loop solveHelp ( ( env, rank ), ( pools, state ), ( constraint, identity ) ) + + +solveHelp : ( ( Env, Int ), ( Pools, State ), ( Type.Constraint, IO State -> IO State ) ) -> IO (IO.Step ( ( Env, Int ), ( Pools, State ), ( Type.Constraint, IO State -> IO State ) ) State) +solveHelp ( ( env, rank ), ( pools, (State _ sMark sErrors) as state ), ( constraint, cont ) ) = + case constraint of + CTrue -> + IO.fmap IO.Done <| cont <| IO.pure state + + CSaveTheEnvironment -> + IO.fmap IO.Done <| cont <| IO.pure (State env sMark sErrors) + + CEqual region category tipe expectation -> + typeToVariable rank pools tipe + |> IO.bind + (\actual -> + expectedToVariable rank pools expectation + |> IO.bind + (\expected -> + Unify.unify actual expected + |> IO.bind + (\answer -> + case answer of + Unify.AnswerOk vars -> + introduce rank pools vars + |> IO.bind (\_ -> IO.fmap IO.Done <| cont <| IO.pure state) + + Unify.AnswerErr vars actualType expectedType -> + introduce rank pools vars + |> IO.bind + (\_ -> + IO.fmap IO.Done <| + cont <| + IO.pure <| + addError state <| + Error.BadExpr region category actualType <| + Error.typeReplace expectation expectedType + ) + ) + ) + ) + + CLocal region name expectation -> + makeCopy rank pools (Utils.find identity name env) + |> IO.bind + (\actual -> + expectedToVariable rank pools expectation + |> IO.bind + (\expected -> + Unify.unify actual expected + |> IO.bind + (\answer -> + case answer of + Unify.AnswerOk vars -> + introduce rank pools vars + |> IO.bind (\_ -> IO.fmap IO.Done <| cont <| IO.pure state) + + Unify.AnswerErr vars actualType expectedType -> + introduce rank pools vars + |> IO.bind + (\_ -> + IO.fmap IO.Done <| + cont <| + IO.pure <| + addError state <| + Error.BadExpr region (Error.Local name) actualType <| + Error.typeReplace expectation expectedType + ) + ) + ) + ) + + CForeign region name (Can.Forall freeVars srcType) expectation -> + srcTypeToVariable rank pools freeVars srcType + |> IO.bind + (\actual -> + expectedToVariable rank pools expectation + |> IO.bind + (\expected -> + Unify.unify actual expected + |> IO.bind + (\answer -> + case answer of + Unify.AnswerOk vars -> + introduce rank pools vars + |> IO.bind (\_ -> IO.fmap IO.Done <| cont <| IO.pure state) + + Unify.AnswerErr vars actualType expectedType -> + introduce rank pools vars + |> IO.bind + (\_ -> + IO.fmap IO.Done <| + cont <| + IO.pure <| + addError state <| + Error.BadExpr region (Error.Foreign name) actualType <| + Error.typeReplace expectation expectedType + ) + ) + ) + ) + + CPattern region category tipe expectation -> + typeToVariable rank pools tipe + |> IO.bind + (\actual -> + patternExpectationToVariable rank pools expectation + |> IO.bind + (\expected -> + Unify.unify actual expected + |> IO.bind + (\answer -> + case answer of + Unify.AnswerOk vars -> + introduce rank pools vars + |> IO.bind (\_ -> IO.fmap IO.Done <| cont <| IO.pure state) + + Unify.AnswerErr vars actualType expectedType -> + introduce rank pools vars + |> IO.bind + (\_ -> + IO.fmap IO.Done <| + cont <| + IO.pure <| + addError state <| + Error.BadPattern region + category + actualType + (Error.ptypeReplace expectation expectedType) + ) + ) + ) + ) + + CAnd constraints -> + IO.fmap IO.Done <| cont <| IO.foldM (solve env rank pools) state constraints + + CLet [] flexs _ headerCon CTrue -> + introduce rank pools flexs + |> IO.fmap (\_ -> IO.Loop ( ( env, rank ), ( pools, state ), ( headerCon, cont ) )) + + CLet [] [] header headerCon subCon -> + solve env rank pools state headerCon + |> IO.bind + (\state1 -> + IO.traverseMap identity compare (A.traverse (typeToVariable rank pools)) header + |> IO.fmap + (\locals -> + let + newEnv : Env + newEnv = + Dict.union env (Dict.map (\_ -> A.toValue) locals) + in + IO.Loop + ( ( newEnv, rank ) + , ( pools, state1 ) + , ( subCon + , IO.bind + (\state2 -> + IO.foldM occurs state2 (Dict.toList compare locals) + ) + >> cont + ) + ) + ) + ) + + CLet rigids flexs header headerCon subCon -> + let + -- work in the next pool to localize header + nextRank : Int + nextRank = + rank + 1 + in + MVector.length pools + |> IO.bind + (\poolsLength -> + (if nextRank < poolsLength then + IO.pure pools + + else + MVector.grow pools poolsLength + ) + |> IO.bind + (\nextPools -> + let + -- introduce variables + vars : List Variable + vars = + rigids ++ flexs + in + IO.forM_ vars + (\var -> + UF.modify var <| + \(Descriptor content _ mark copy) -> + Descriptor content nextRank mark copy + ) + |> IO.bind + (\_ -> + MVector.write nextPools nextRank vars + |> IO.bind + (\_ -> + -- run solver in next pool + IO.traverseMap identity compare (A.traverse (typeToVariable nextRank nextPools)) header + |> IO.bind + (\locals -> + solve env nextRank nextPools state headerCon + |> IO.bind + (\(State savedEnv mark errors) -> + let + youngMark : Mark + youngMark = + mark + + visitMark : Mark + visitMark = + nextMark youngMark + + finalMark : Mark + finalMark = + nextMark visitMark + in + -- pop pool + generalize youngMark visitMark nextRank nextPools + |> IO.bind + (\_ -> + MVector.write nextPools nextRank [] + |> IO.bind + (\_ -> + -- check that things went well + IO.mapM_ isGeneric rigids + |> IO.fmap + (\_ -> + let + newEnv : Env + newEnv = + Dict.union env (Dict.map (\_ -> A.toValue) locals) + + tempState : State + tempState = + State savedEnv finalMark errors + in + IO.Loop + ( ( newEnv, rank ) + , ( nextPools, tempState ) + , ( subCon + , IO.bind + (\newState -> + IO.foldM occurs newState (Dict.toList compare locals) + ) + >> cont + ) + ) + ) + ) + ) + ) + ) + ) + ) + ) + ) + + + +-- Check that a variable has rank == noRank, meaning that it can be generalized. + + +isGeneric : Variable -> IO () +isGeneric var = + UF.get var + |> IO.bind + (\(Descriptor _ rank _ _) -> + if rank == Type.noRank then + IO.pure () + + else + Type.toErrorType var + |> IO.bind + (\tipe -> + crash <| + "You ran into a compiler bug. Here are some details for the developers:\n\n" + ++ " " + ++ Doc.toString (ET.toDoc L.empty RT.None tipe) + ++ " [rank = " + ++ String.fromInt rank + ++ "]\n\n" + ++ "Please create an and then report it\nat \n\n" + ) + ) + + + +-- EXPECTATIONS TO VARIABLE + + +expectedToVariable : Int -> Pools -> Error.Expected Type -> IO Variable +expectedToVariable rank pools expectation = + typeToVariable rank pools <| + case expectation of + Error.NoExpectation tipe -> + tipe + + Error.FromContext _ _ tipe -> + tipe + + Error.FromAnnotation _ _ _ tipe -> + tipe + + +patternExpectationToVariable : Int -> Pools -> Error.PExpected Type -> IO Variable +patternExpectationToVariable rank pools expectation = + typeToVariable rank pools <| + case expectation of + Error.PNoExpectation tipe -> + tipe + + Error.PFromContext _ _ tipe -> + tipe + + + +-- ERROR HELPERS + + +addError : State -> Error.Error -> State +addError (State savedEnv rank errors) err = + State savedEnv rank (err :: errors) + + + +-- OCCURS CHECK + + +occurs : State -> ( Name.Name, A.Located Variable ) -> IO State +occurs state ( name, A.At region variable ) = + Occurs.occurs variable + |> IO.bind + (\hasOccurred -> + if hasOccurred then + Type.toErrorType variable + |> IO.bind + (\errorType -> + UF.get variable + |> IO.bind + (\(Descriptor _ rank mark copy) -> + UF.set variable (Descriptor IO.Error rank mark copy) + |> IO.fmap (\_ -> addError state (Error.InfiniteType region name errorType)) + ) + ) + + else + IO.pure state + ) + + + +-- GENERALIZE + + +{-| Every variable has rank less than or equal to the maxRank of the pool. +This sorts variables into the young and old pools accordingly. +-} +generalize : Mark -> Mark -> Int -> Pools -> IO () +generalize youngMark visitMark youngRank pools = + MVector.read pools youngRank + |> IO.bind + (\youngVars -> + poolToRankTable youngMark youngRank youngVars + |> IO.bind + (\rankTable -> + -- get the ranks right for each entry. + -- start at low ranks so that we only have to pass + -- over the information once. + Vector.imapM_ + (\rank table -> + IO.mapM_ (adjustRank youngMark visitMark rank) table + ) + rankTable + |> IO.bind + (\_ -> + -- For variables that have rank lowerer than youngRank, register them in + -- the appropriate old pool if they are not redundant. + Vector.forM_ (Vector.unsafeInit rankTable) + (\vars -> + IO.forM_ vars + (\var -> + UF.redundant var + |> IO.bind + (\isRedundant -> + if isRedundant then + IO.pure () + + else + UF.get var + |> IO.bind + (\(Descriptor _ rank _ _) -> + MVector.modify pools ((::) var) rank + ) + ) + ) + ) + |> IO.bind + (\_ -> + -- For variables with rank youngRank + -- If rank < youngRank: register in oldPool + -- otherwise generalize + Vector.unsafeLast rankTable + |> IO.bind + (\lastRankTable -> + IO.forM_ lastRankTable <| + \var -> + UF.redundant var + |> IO.bind + (\isRedundant -> + if isRedundant then + IO.pure () + + else + UF.get var + |> IO.bind + (\(Descriptor content rank mark copy) -> + if rank < youngRank then + MVector.modify pools ((::) var) rank + + else + UF.set var <| Descriptor content Type.noRank mark copy + ) + ) + ) + ) + ) + ) + ) + + +poolToRankTable : Mark -> Int -> List Variable -> IO (IORef (Array (Maybe (List Variable)))) +poolToRankTable youngMark youngRank youngInhabitants = + MVector.replicate (youngRank + 1) [] + |> IO.bind + (\mutableTable -> + -- Sort the youngPool variables into buckets by rank. + IO.forM_ youngInhabitants + (\var -> + UF.get var + |> IO.bind + (\(Descriptor content rank _ copy) -> + UF.set var (Descriptor content rank youngMark copy) + |> IO.bind + (\_ -> + MVector.modify mutableTable ((::) var) rank + ) + ) + ) + |> IO.bind (\_ -> Vector.unsafeFreeze mutableTable) + ) + + + +-- ADJUST RANK +-- +-- Adjust variable ranks such that ranks never increase as you move deeper. +-- This way the outermost rank is representative of the entire structure. +-- + + +adjustRank : Mark -> Mark -> Int -> Variable -> IO Int +adjustRank youngMark visitMark groupRank var = + UF.get var + |> IO.bind + (\(Descriptor content rank mark copy) -> + if mark == youngMark then + -- Set the variable as marked first because it may be cyclic. + UF.set var (Descriptor content rank visitMark copy) + |> IO.bind + (\_ -> + adjustRankContent youngMark visitMark groupRank content + |> IO.bind + (\maxRank -> + UF.set var (Descriptor content maxRank visitMark copy) + |> IO.fmap (\_ -> maxRank) + ) + ) + + else if mark == visitMark then + IO.pure rank + + else + let + minRank : Int + minRank = + min groupRank rank + in + -- TODO how can minRank ever be groupRank? + UF.set var (Descriptor content minRank visitMark copy) + |> IO.fmap (\_ -> minRank) + ) + + +adjustRankContent : Mark -> Mark -> Int -> Content -> IO Int +adjustRankContent youngMark visitMark groupRank content = + let + go : Variable -> IO Int + go = + adjustRank youngMark visitMark groupRank + in + case content of + IO.FlexVar _ -> + IO.pure groupRank + + IO.FlexSuper _ _ -> + IO.pure groupRank + + IO.RigidVar _ -> + IO.pure groupRank + + IO.RigidSuper _ _ -> + IO.pure groupRank + + IO.Structure flatType -> + case flatType of + IO.App1 _ _ args -> + IO.foldM (\rank arg -> IO.fmap (max rank) (go arg)) Type.outermostRank args + + IO.Fun1 arg result -> + IO.pure max + |> IO.apply (go arg) + |> IO.apply (go result) + + IO.EmptyRecord1 -> + -- THEORY: an empty record never needs to get generalized + IO.pure Type.outermostRank + + IO.Record1 fields extension -> + go extension + |> IO.bind + (\extRank -> + IO.foldMDict compare (\rank field -> IO.fmap (max rank) (go field)) extRank fields + ) + + IO.Unit1 -> + -- THEORY: a unit never needs to get generalized + IO.pure Type.outermostRank + + IO.Tuple1 a b cs -> + go a + |> IO.bind + (\ma -> + go b + |> IO.bind + (\mb -> + IO.foldM (\rank -> IO.fmap (max rank) << go) (max ma mb) cs + ) + ) + + IO.Alias _ _ args _ -> + -- THEORY: anything in the realVar would be outermostRank + IO.foldM (\rank ( _, argVar ) -> IO.fmap (max rank) (go argVar)) Type.outermostRank args + + IO.Error -> + IO.pure groupRank + + + +-- REGISTER VARIABLES + + +introduce : Int -> Pools -> List Variable -> IO () +introduce rank pools variables = + MVector.modify pools + (\a -> variables ++ a) + rank + |> IO.bind + (\_ -> + IO.forM_ variables + (\var -> + UF.modify var <| + \(Descriptor content _ mark copy) -> + Descriptor content rank mark copy + ) + ) + + + +-- TYPE TO VARIABLE + + +typeToVariable : Int -> Pools -> Type -> IO Variable +typeToVariable rank pools tipe = + typeToVar rank pools Dict.empty tipe + + + +-- PERF working with @mgriffith we noticed that a 784 line entry in a `let` was +-- causing a ~1.5 second slowdown. Moving it to the top-level to be a function +-- saved all that time. The slowdown seems to manifest in `typeToVar` and in +-- `register` in particular. Have not explored further yet. Top-level definitions +-- are recommended in cases like this anyway, so there is at least a safety +-- valve for now. +-- + + +typeToVar : Int -> Pools -> Dict String Name.Name Variable -> Type -> IO Variable +typeToVar rank pools aliasDict tipe = + let + go : Type -> IO Variable + go = + typeToVar rank pools aliasDict + in + case tipe of + Type.VarN v -> + IO.pure v + + Type.AppN home name args -> + IO.traverseList go args + |> IO.bind + (\argVars -> + register rank pools (IO.Structure (IO.App1 home name argVars)) + ) + + Type.FunN a b -> + go a + |> IO.bind + (\aVar -> + go b + |> IO.bind + (\bVar -> + register rank pools (IO.Structure (IO.Fun1 aVar bVar)) + ) + ) + + Type.AliasN home name args aliasType -> + IO.traverseList (IO.traverseTuple go) args + |> IO.bind + (\argVars -> + typeToVar rank pools (Dict.fromList identity argVars) aliasType + |> IO.bind + (\aliasVar -> + register rank pools (IO.Alias home name argVars aliasVar) + ) + ) + + Type.PlaceHolder name -> + IO.pure (Utils.find identity name aliasDict) + + Type.RecordN fields ext -> + IO.traverseMap identity compare go fields + |> IO.bind + (\fieldVars -> + go ext + |> IO.bind + (\extVar -> + register rank pools (IO.Structure (IO.Record1 fieldVars extVar)) + ) + ) + + Type.EmptyRecordN -> + register rank pools emptyRecord1 + + Type.UnitN -> + register rank pools unit1 + + Type.TupleN a b cs -> + go a + |> IO.bind + (\aVar -> + go b + |> IO.bind + (\bVar -> + IO.traverseList go cs + |> IO.bind + (\cVars -> + register rank pools (IO.Structure (IO.Tuple1 aVar bVar cVars)) + ) + ) + ) + + +register : Int -> Pools -> Content -> IO Variable +register rank pools content = + UF.fresh (Descriptor content rank Type.noMark Nothing) + |> IO.bind + (\var -> + MVector.modify pools ((::) var) rank + |> IO.fmap (\_ -> var) + ) + + +emptyRecord1 : Content +emptyRecord1 = + IO.Structure IO.EmptyRecord1 + + +unit1 : Content +unit1 = + IO.Structure IO.Unit1 + + + +-- SOURCE TYPE TO VARIABLE + + +srcTypeToVariable : Int -> Pools -> Dict String Name.Name () -> Can.Type -> IO Variable +srcTypeToVariable rank pools freeVars srcType = + let + nameToContent : Name.Name -> Content + nameToContent name = + if Name.isNumberType name then + IO.FlexSuper IO.Number (Just name) + + else if Name.isComparableType name then + IO.FlexSuper IO.Comparable (Just name) + + else if Name.isAppendableType name then + IO.FlexSuper IO.Appendable (Just name) + + else if Name.isCompappendType name then + IO.FlexSuper IO.CompAppend (Just name) + + else + IO.FlexVar (Just name) + + makeVar : Name.Name -> b -> IO Variable + makeVar name _ = + UF.fresh (Descriptor (nameToContent name) rank Type.noMark Nothing) + in + IO.traverseMapWithKey identity compare makeVar freeVars + |> IO.bind + (\flexVars -> + MVector.modify pools (\a -> Dict.values compare flexVars ++ a) rank + |> IO.bind (\_ -> srcTypeToVar rank pools flexVars srcType) + ) + + +srcTypeToVar : Int -> Pools -> Dict String Name.Name Variable -> Can.Type -> IO Variable +srcTypeToVar rank pools flexVars srcType = + let + go : Can.Type -> IO Variable + go = + srcTypeToVar rank pools flexVars + in + case srcType of + Can.TLambda argument result -> + go argument + |> IO.bind + (\argVar -> + go result + |> IO.bind + (\resultVar -> + register rank pools (IO.Structure (IO.Fun1 argVar resultVar)) + ) + ) + + Can.TVar name -> + IO.pure (Utils.find identity name flexVars) + + Can.TType home name args -> + IO.traverseList go args + |> IO.bind + (\argVars -> + register rank pools (IO.Structure (IO.App1 home name argVars)) + ) + + Can.TRecord fields maybeExt -> + IO.traverseMap identity compare (srcFieldTypeToVar rank pools flexVars) fields + |> IO.bind + (\fieldVars -> + (case maybeExt of + Nothing -> + register rank pools emptyRecord1 + + Just ext -> + IO.pure (Utils.find identity ext flexVars) + ) + |> IO.bind + (\extVar -> + register rank pools (IO.Structure (IO.Record1 fieldVars extVar)) + ) + ) + + Can.TUnit -> + register rank pools unit1 + + Can.TTuple a b cs -> + go a + |> IO.bind + (\aVar -> + go b + |> IO.bind + (\bVar -> + IO.traverseList go cs + |> IO.bind + (\cVars -> + register rank pools (IO.Structure (IO.Tuple1 aVar bVar cVars)) + ) + ) + ) + + Can.TAlias home name args aliasType -> + IO.traverseList (IO.traverseTuple go) args + |> IO.bind + (\argVars -> + (case aliasType of + Can.Holey tipe -> + srcTypeToVar rank pools (Dict.fromList identity argVars) tipe + + Can.Filled tipe -> + go tipe + ) + |> IO.bind + (\aliasVar -> + register rank pools (IO.Alias home name argVars aliasVar) + ) + ) + + +srcFieldTypeToVar : Int -> Pools -> Dict String Name.Name Variable -> Can.FieldType -> IO Variable +srcFieldTypeToVar rank pools flexVars (Can.FieldType _ srcTipe) = + srcTypeToVar rank pools flexVars srcTipe + + + +-- COPY + + +makeCopy : Int -> Pools -> Variable -> IO Variable +makeCopy rank pools var = + makeCopyHelp rank pools var + |> IO.bind + (\copy -> + restore var + |> IO.fmap (\_ -> copy) + ) + + +makeCopyHelp : Int -> Pools -> Variable -> IO Variable +makeCopyHelp maxRank pools variable = + UF.get variable + |> IO.bind + (\(Descriptor content rank _ maybeCopy) -> + case maybeCopy of + Just copy -> + IO.pure copy + + Nothing -> + if rank /= Type.noRank then + IO.pure variable + + else + let + makeDescriptor : Content -> Descriptor + makeDescriptor c = + Descriptor c maxRank Type.noMark Nothing + in + UF.fresh (makeDescriptor content) + |> IO.bind + (\copy -> + MVector.modify pools ((::) copy) maxRank + |> IO.bind + (\_ -> + -- Link the original variable to the new variable. This lets us + -- avoid making multiple copies of the variable we are instantiating. + -- + -- Need to do this before recursively copying to avoid looping. + UF.set variable (Descriptor content rank Type.noMark (Just copy)) + |> IO.bind + (\_ -> + -- Now we recursively copy the content of the variable. + -- We have already marked the variable as copied, so we + -- will not repeat this work or crawl this variable again. + case content of + IO.Structure term -> + traverseFlatType (makeCopyHelp maxRank pools) term + |> IO.bind + (\newTerm -> + UF.set copy (makeDescriptor (IO.Structure newTerm)) + |> IO.fmap (\_ -> copy) + ) + + IO.FlexVar _ -> + IO.pure copy + + IO.FlexSuper _ _ -> + IO.pure copy + + IO.RigidVar name -> + UF.set copy (makeDescriptor (IO.FlexVar (Just name))) + |> IO.fmap (\_ -> copy) + + IO.RigidSuper super name -> + UF.set copy (makeDescriptor (IO.FlexSuper super (Just name))) + |> IO.fmap (\_ -> copy) + + IO.Alias home name args realType -> + IO.mapM (IO.traverseTuple (makeCopyHelp maxRank pools)) args + |> IO.bind + (\newArgs -> + makeCopyHelp maxRank pools realType + |> IO.bind + (\newRealType -> + UF.set copy (makeDescriptor (IO.Alias home name newArgs newRealType)) + |> IO.fmap (\_ -> copy) + ) + ) + + IO.Error -> + IO.pure copy + ) + ) + ) + ) + + + +-- RESTORE + + +restore : Variable -> IO () +restore variable = + UF.get variable + |> IO.bind + (\(Descriptor content _ _ maybeCopy) -> + case maybeCopy of + Nothing -> + IO.pure () + + Just _ -> + UF.set variable (Descriptor content Type.noRank Type.noMark Nothing) + |> IO.bind (\_ -> restoreContent content) + ) + + +restoreContent : Content -> IO () +restoreContent content = + case content of + IO.FlexVar _ -> + IO.pure () + + IO.FlexSuper _ _ -> + IO.pure () + + IO.RigidVar _ -> + IO.pure () + + IO.RigidSuper _ _ -> + IO.pure () + + IO.Structure term -> + case term of + IO.App1 _ _ args -> + IO.mapM_ restore args + + IO.Fun1 arg result -> + restore arg + |> IO.bind (\_ -> restore result) + + IO.EmptyRecord1 -> + IO.pure () + + IO.Record1 fields ext -> + IO.mapM_ restore (Dict.values compare fields) + |> IO.bind (\_ -> restore ext) + + IO.Unit1 -> + IO.pure () + + IO.Tuple1 a b cs -> + IO.traverseList restore (a :: b :: cs) + |> IO.fmap (\_ -> ()) + + IO.Alias _ _ args var -> + IO.mapM_ restore (List.map Tuple.second args) + |> IO.bind (\_ -> restore var) + + IO.Error -> + IO.pure () + + + +-- TRAVERSE FLAT TYPE + + +traverseFlatType : (Variable -> IO Variable) -> IO.FlatType -> IO IO.FlatType +traverseFlatType f flatType = + case flatType of + IO.App1 home name args -> + IO.fmap (IO.App1 home name) (IO.traverseList f args) + + IO.Fun1 a b -> + IO.pure IO.Fun1 + |> IO.apply (f a) + |> IO.apply (f b) + + IO.EmptyRecord1 -> + IO.pure IO.EmptyRecord1 + + IO.Record1 fields ext -> + IO.pure IO.Record1 + |> IO.apply (IO.traverseMap identity compare f fields) + |> IO.apply (f ext) + + IO.Unit1 -> + IO.pure IO.Unit1 + + IO.Tuple1 a b cs -> + IO.pure IO.Tuple1 + |> IO.apply (f a) + |> IO.apply (f b) + |> IO.apply (IO.traverseList f cs) diff --git a/src/Compiler/Type/Type.elm b/src/Compiler/Type/Type.elm new file mode 100644 index 0000000000..ab0b1383aa --- /dev/null +++ b/src/Compiler/Type/Type.elm @@ -0,0 +1,808 @@ +module Compiler.Type.Type exposing + ( Constraint(..) + , Type(..) + , bool + , char + , exists + , float + , funType + , int + , mat4 + , mkFlexNumber + , mkFlexVar + , nameToFlex + , nameToRigid + , never + , nextMark + , noMark + , noRank + , outermostRank + , string + , texture + , toAnnotation + , toErrorType + , unnamedFlexSuper + , unnamedFlexVar + , vec2 + , vec3 + , vec4 + ) + +import Compiler.AST.Canonical as Can +import Compiler.AST.Utils.Type as Type +import Compiler.Data.Name as Name exposing (Name) +import Compiler.Elm.ModuleName as ModuleName +import Compiler.Reporting.Annotation as A +import Compiler.Reporting.Error.Type as E +import Compiler.Type.Error as ET +import Compiler.Type.UnionFind as UF +import Control.Monad.State.TypeCheck.Strict as State exposing (StateT, liftIO) +import Data.Map as Dict exposing (Dict) +import Maybe.Extra as Maybe +import System.TypeCheck.IO as IO exposing (Content(..), Descriptor(..), FlatType(..), IO, Mark(..), SuperType(..), Variable) +import Utils.Crash exposing (crash) + + + +-- CONSTRAINTS + + +type Constraint + = CTrue + | CSaveTheEnvironment + | CEqual A.Region E.Category Type (E.Expected Type) + | CLocal A.Region Name (E.Expected Type) + | CForeign A.Region Name Can.Annotation (E.Expected Type) + | CPattern A.Region E.PCategory Type (E.PExpected Type) + | CAnd (List Constraint) + | CLet (List Variable) (List Variable) (Dict String Name (A.Located Type)) Constraint Constraint + + +exists : List Variable -> Constraint -> Constraint +exists flexVars constraint = + CLet [] flexVars Dict.empty constraint CTrue + + + +-- TYPE PRIMITIVES + + +type Type + = PlaceHolder Name + | AliasN IO.Canonical Name (List ( Name, Type )) Type + | VarN Variable + | AppN IO.Canonical Name (List Type) + | FunN Type Type + | EmptyRecordN + | RecordN (Dict String Name Type) Type + | UnitN + | TupleN Type Type (List Type) + + + +-- DESCRIPTORS + + +makeDescriptor : Content -> Descriptor +makeDescriptor content = + Descriptor content noRank noMark Nothing + + + +-- RANKS + + +noRank : Int +noRank = + 0 + + +outermostRank : Int +outermostRank = + 1 + + + +-- MARKS + + +noMark : Mark +noMark = + Mark 2 + + +occursMark : Mark +occursMark = + Mark 1 + + +getVarNamesMark : Mark +getVarNamesMark = + Mark 0 + + +nextMark : Mark -> Mark +nextMark (Mark mark) = + Mark (mark + 1) + + + +-- FUNCTION TYPES + + +funType : Type -> Type -> Type +funType = + FunN + + + +-- PRIMITIVE TYPES + + +int : Type +int = + AppN ModuleName.basics "Int" [] + + +float : Type +float = + AppN ModuleName.basics "Float" [] + + +char : Type +char = + AppN ModuleName.char "Char" [] + + +string : Type +string = + AppN ModuleName.string "String" [] + + +bool : Type +bool = + AppN ModuleName.basics "Bool" [] + + +never : Type +never = + AppN ModuleName.basics "Never" [] + + + +-- WEBGL TYPES + + +vec2 : Type +vec2 = + AppN ModuleName.vector2 "Vec2" [] + + +vec3 : Type +vec3 = + AppN ModuleName.vector3 "Vec3" [] + + +vec4 : Type +vec4 = + AppN ModuleName.vector4 "Vec4" [] + + +mat4 : Type +mat4 = + AppN ModuleName.matrix4 "Mat4" [] + + +texture : Type +texture = + AppN ModuleName.texture "Texture" [] + + + +-- MAKE FLEX VARIABLES + + +mkFlexVar : IO Variable +mkFlexVar = + UF.fresh flexVarDescriptor + + +flexVarDescriptor : Descriptor +flexVarDescriptor = + makeDescriptor unnamedFlexVar + + +unnamedFlexVar : Content +unnamedFlexVar = + FlexVar Nothing + + + +-- MAKE FLEX NUMBERS + + +mkFlexNumber : IO Variable +mkFlexNumber = + UF.fresh flexNumberDescriptor + + +flexNumberDescriptor : Descriptor +flexNumberDescriptor = + makeDescriptor (unnamedFlexSuper Number) + + +unnamedFlexSuper : SuperType -> Content +unnamedFlexSuper super = + FlexSuper super Nothing + + + +-- MAKE NAMED VARIABLES + + +nameToFlex : Name -> IO Variable +nameToFlex name = + UF.fresh <| + makeDescriptor <| + Maybe.unwrap FlexVar FlexSuper (toSuper name) (Just name) + + +nameToRigid : Name -> IO Variable +nameToRigid name = + UF.fresh <| + makeDescriptor <| + Maybe.unwrap RigidVar RigidSuper (toSuper name) name + + +toSuper : Name -> Maybe SuperType +toSuper name = + if Name.isNumberType name then + Just Number + + else if Name.isComparableType name then + Just Comparable + + else if Name.isAppendableType name then + Just Appendable + + else if Name.isCompappendType name then + Just CompAppend + + else + Nothing + + + +-- TO TYPE ANNOTATION + + +toAnnotation : Variable -> IO Can.Annotation +toAnnotation variable = + getVarNames variable Dict.empty + |> IO.bind + (\userNames -> + State.runStateT (variableToCanType variable) (makeNameState userNames) + |> IO.fmap + (\( tipe, NameState freeVars _ _ _ _ _ ) -> + Can.Forall freeVars tipe + ) + ) + + +variableToCanType : Variable -> State.StateT NameState Can.Type +variableToCanType variable = + liftIO (UF.get variable) + |> State.bind + (\(Descriptor content _ _ _) -> + case content of + Structure term -> + termToCanType term + + FlexVar maybeName -> + case maybeName of + Just name -> + State.pure (Can.TVar name) + + Nothing -> + getFreshVarName + |> State.bind + (\name -> + liftIO + (UF.modify variable + (\(Descriptor _ rank mark copy) -> + Descriptor (FlexVar (Just name)) rank mark copy + ) + ) + |> State.fmap (\_ -> Can.TVar name) + ) + + FlexSuper super maybeName -> + case maybeName of + Just name -> + State.pure (Can.TVar name) + + Nothing -> + getFreshSuperName super + |> State.bind + (\name -> + liftIO + (UF.modify variable + (\(Descriptor _ rank mark copy) -> + Descriptor (FlexSuper super (Just name)) rank mark copy + ) + ) + |> State.fmap (\_ -> Can.TVar name) + ) + + RigidVar name -> + State.pure (Can.TVar name) + + RigidSuper _ name -> + State.pure (Can.TVar name) + + Alias home name args realVariable -> + State.traverseList (State.traverseTuple variableToCanType) args + |> State.bind + (\canArgs -> + variableToCanType realVariable + |> State.fmap + (\canType -> + Can.TAlias home name canArgs (Can.Filled canType) + ) + ) + + Error -> + crash "cannot handle Error types in variableToCanType" + ) + + +termToCanType : FlatType -> StateT NameState Can.Type +termToCanType term = + case term of + App1 home name args -> + State.traverseList variableToCanType args + |> State.fmap (Can.TType home name) + + Fun1 a b -> + State.pure Can.TLambda + |> State.apply (variableToCanType a) + |> State.apply (variableToCanType b) + + EmptyRecord1 -> + State.pure (Can.TRecord Dict.empty Nothing) + + Record1 fields extension -> + State.traverseMap compare identity fieldToCanType fields + |> State.bind + (\canFields -> + variableToCanType extension + |> State.fmap Type.iteratedDealias + |> State.fmap + (\canExt -> + case canExt of + Can.TRecord subFields subExt -> + Can.TRecord (Dict.union subFields canFields) subExt + + Can.TVar name -> + Can.TRecord canFields (Just name) + + _ -> + crash "Used toAnnotation on a type that is not well-formed" + ) + ) + + Unit1 -> + State.pure Can.TUnit + + Tuple1 a b cs -> + State.pure Can.TTuple + |> State.apply (variableToCanType a) + |> State.apply (variableToCanType b) + |> State.apply (State.traverseList variableToCanType cs) + + +fieldToCanType : Variable -> StateT NameState Can.FieldType +fieldToCanType variable = + variableToCanType variable + |> State.fmap (\tipe -> Can.FieldType 0 tipe) + + + +-- TO ERROR TYPE + + +toErrorType : Variable -> IO ET.Type +toErrorType variable = + getVarNames variable Dict.empty + |> IO.bind + (\userNames -> + State.evalStateT (variableToErrorType variable) (makeNameState userNames) + ) + + +variableToErrorType : Variable -> StateT NameState ET.Type +variableToErrorType variable = + liftIO (UF.get variable) + |> State.bind + (\(Descriptor content _ mark _) -> + if mark == occursMark then + State.pure ET.Infinite + + else + liftIO (UF.modify variable (\(Descriptor content_ rank_ _ copy_) -> Descriptor content_ rank_ occursMark copy_)) + |> State.bind + (\_ -> + contentToErrorType variable content + |> State.bind + (\errType -> + liftIO (UF.modify variable (\(Descriptor content_ rank_ _ copy_) -> Descriptor content_ rank_ mark copy_)) + |> State.fmap (\_ -> errType) + ) + ) + ) + + +contentToErrorType : Variable -> Content -> StateT NameState ET.Type +contentToErrorType variable content = + case content of + Structure term -> + termToErrorType term + + FlexVar maybeName -> + case maybeName of + Just name -> + State.pure (ET.FlexVar name) + + Nothing -> + getFreshVarName + |> State.bind + (\name -> + liftIO + (UF.modify variable + (\(Descriptor _ rank mark copy) -> + Descriptor (FlexVar (Just name)) rank mark copy + ) + ) + |> State.fmap (\_ -> ET.FlexVar name) + ) + + FlexSuper super maybeName -> + case maybeName of + Just name -> + State.pure (ET.FlexSuper (superToSuper super) name) + + Nothing -> + getFreshSuperName super + |> State.bind + (\name -> + liftIO + (UF.modify variable + (\(Descriptor _ rank mark copy) -> + Descriptor (FlexSuper super (Just name)) rank mark copy + ) + ) + |> State.fmap (\_ -> ET.FlexSuper (superToSuper super) name) + ) + + RigidVar name -> + State.pure (ET.RigidVar name) + + RigidSuper super name -> + State.pure (ET.RigidSuper (superToSuper super) name) + + Alias home name args realVariable -> + State.traverseList (State.traverseTuple variableToErrorType) args + |> State.bind + (\errArgs -> + variableToErrorType realVariable + |> State.fmap + (\errType -> + ET.Alias home name errArgs errType + ) + ) + + Error -> + State.pure ET.Error + + +superToSuper : SuperType -> ET.Super +superToSuper super = + case super of + Number -> + ET.Number + + Comparable -> + ET.Comparable + + Appendable -> + ET.Appendable + + CompAppend -> + ET.CompAppend + + +termToErrorType : FlatType -> StateT NameState ET.Type +termToErrorType term = + case term of + App1 home name args -> + State.traverseList variableToErrorType args + |> State.fmap (ET.Type home name) + + Fun1 a b -> + variableToErrorType a + |> State.bind + (\arg -> + variableToErrorType b + |> State.fmap + (\result -> + case result of + ET.Lambda arg1 arg2 others -> + ET.Lambda arg arg1 (arg2 :: others) + + _ -> + ET.Lambda arg result [] + ) + ) + + EmptyRecord1 -> + State.pure (ET.Record Dict.empty ET.Closed) + + Record1 fields extension -> + State.traverseMap compare identity variableToErrorType fields + |> State.bind + (\errFields -> + variableToErrorType extension + |> State.fmap ET.iteratedDealias + |> State.fmap + (\errExt -> + case errExt of + ET.Record subFields subExt -> + ET.Record (Dict.union subFields errFields) subExt + + ET.FlexVar ext -> + ET.Record errFields (ET.FlexOpen ext) + + ET.RigidVar ext -> + ET.Record errFields (ET.RigidOpen ext) + + _ -> + crash "Used toErrorType on a type that is not well-formed" + ) + ) + + Unit1 -> + State.pure ET.Unit + + Tuple1 a b cs -> + State.pure ET.Tuple + |> State.apply (variableToErrorType a) + |> State.apply (variableToErrorType b) + |> State.apply (State.traverseList variableToErrorType cs) + + + +-- MANAGE FRESH VARIABLE NAMES + + +type NameState + = NameState (Dict String Name ()) Int Int Int Int Int + + +makeNameState : Dict String Name Variable -> NameState +makeNameState taken = + NameState (Dict.map (\_ _ -> ()) taken) 0 0 0 0 0 + + + +-- FRESH VAR NAMES + + +getFreshVarName : StateT NameState Name +getFreshVarName = + State.gets (\(NameState _ normals _ _ _ _) -> normals) + |> State.bind + (\index -> + State.gets (\(NameState taken _ _ _ _ _) -> taken) + |> State.bind + (\taken -> + let + ( name, newIndex, newTaken ) = + getFreshVarNameHelp index taken + in + State.modify + (\(NameState _ _ numbers comparables appendables compAppends) -> + NameState newTaken newIndex numbers comparables appendables compAppends + ) + |> State.fmap (\_ -> name) + ) + ) + + +getFreshVarNameHelp : Int -> Dict String Name () -> ( Name, Int, Dict String Name () ) +getFreshVarNameHelp index taken = + let + name : Name + name = + Name.fromTypeVariableScheme index + in + if Dict.member identity name taken then + getFreshVarNameHelp (index + 1) taken + + else + ( name, index + 1, Dict.insert identity name () taken ) + + + +-- FRESH SUPER NAMES + + +getFreshSuperName : SuperType -> StateT NameState Name +getFreshSuperName super = + case super of + Number -> + getFreshSuper "number" + (\(NameState _ _ numbers _ _ _) -> numbers) + (\index (NameState taken normals _ comparables appendables compAppends) -> + NameState taken normals index comparables appendables compAppends + ) + + Comparable -> + getFreshSuper "comparable" + (\(NameState _ _ _ comparables _ _) -> comparables) + (\index (NameState taken normals numbers _ appendables compAppends) -> + NameState taken normals numbers index appendables compAppends + ) + + Appendable -> + getFreshSuper "appendable" + (\(NameState _ _ _ _ appendables _) -> appendables) + (\index (NameState taken normals numbers comparables _ compAppends) -> + NameState taken normals numbers comparables index compAppends + ) + + CompAppend -> + getFreshSuper "compappend" + (\(NameState _ _ _ _ _ compAppends) -> compAppends) + (\index (NameState taken normals numbers comparables appendables _) -> + NameState taken normals numbers comparables appendables index + ) + + +getFreshSuper : Name -> (NameState -> Int) -> (Int -> NameState -> NameState) -> StateT NameState Name +getFreshSuper prefix getter setter = + State.gets getter + |> State.bind + (\index -> + State.gets (\(NameState taken _ _ _ _ _) -> taken) + |> State.bind + (\taken -> + let + ( name, newIndex, newTaken ) = + getFreshSuperHelp prefix index taken + in + State.modify + (\(NameState _ normals numbers comparables appendables compAppends) -> + setter newIndex (NameState newTaken normals numbers comparables appendables compAppends) + ) + |> State.fmap (\_ -> name) + ) + ) + + +getFreshSuperHelp : Name -> Int -> Dict String Name () -> ( Name, Int, Dict String Name () ) +getFreshSuperHelp prefix index taken = + let + name : Name + name = + Name.fromTypeVariable prefix index + in + if Dict.member identity name taken then + getFreshSuperHelp prefix (index + 1) taken + + else + ( name, index + 1, Dict.insert identity name () taken ) + + + +-- GET ALL VARIABLE NAMES + + +getVarNames : Variable -> Dict String Name Variable -> IO (Dict String Name Variable) +getVarNames var takenNames = + UF.get var + |> IO.bind + (\(Descriptor content rank mark copy) -> + if mark == getVarNamesMark then + IO.pure takenNames + + else + UF.set var (Descriptor content rank getVarNamesMark copy) + |> IO.bind + (\_ -> + case content of + Error -> + IO.pure takenNames + + FlexVar maybeName -> + case maybeName of + Nothing -> + IO.pure takenNames + + Just name -> + addName 0 name var (FlexVar << Just) takenNames + + FlexSuper super maybeName -> + case maybeName of + Nothing -> + IO.pure takenNames + + Just name -> + addName 0 name var (FlexSuper super << Just) takenNames + + RigidVar name -> + addName 0 name var RigidVar takenNames + + RigidSuper super name -> + addName 0 name var (RigidSuper super) takenNames + + Alias _ _ args _ -> + IO.foldrM getVarNames takenNames (List.map Tuple.second args) + + Structure flatType -> + case flatType of + App1 _ _ args -> + IO.foldrM getVarNames takenNames args + + Fun1 arg body -> + IO.bind (getVarNames arg) (getVarNames body takenNames) + + EmptyRecord1 -> + IO.pure takenNames + + Record1 fields extension -> + IO.bind (getVarNames extension) + (IO.foldrM getVarNames takenNames (Dict.values compare fields)) + + Unit1 -> + IO.pure takenNames + + Tuple1 a b cs -> + IO.foldrM getVarNames takenNames (a :: b :: cs) + ) + ) + + + +-- REGISTER NAME / RENAME DUPLICATES + + +addName : Int -> Name -> Variable -> (Name -> Content) -> Dict String Name Variable -> IO (Dict String Name Variable) +addName index givenName var makeContent takenNames = + let + indexedName : Name + indexedName = + Name.fromTypeVariable givenName index + in + case Dict.get identity indexedName takenNames of + Nothing -> + (if indexedName == givenName then + IO.pure () + + else + UF.modify var + (\(Descriptor _ rank mark copy) -> + Descriptor (makeContent indexedName) rank mark copy + ) + ) + |> IO.fmap (\_ -> Dict.insert identity indexedName var takenNames) + + Just otherVar -> + UF.equivalent var otherVar + |> IO.bind + (\same -> + if same then + IO.pure takenNames + + else + addName (index + 1) givenName var makeContent takenNames + ) diff --git a/src/Compiler/Type/Unify.elm b/src/Compiler/Type/Unify.elm new file mode 100644 index 0000000000..e0f9082d4f --- /dev/null +++ b/src/Compiler/Type/Unify.elm @@ -0,0 +1,877 @@ +module Compiler.Type.Unify exposing + ( Answer(..) + , unify + ) + +import Compiler.Data.Name as Name +import Compiler.Elm.ModuleName as ModuleName +import Compiler.Type.Error as Error +import Compiler.Type.Occurs as Occurs +import Compiler.Type.Type as Type +import Compiler.Type.UnionFind as UF +import Data.Map as Dict exposing (Dict) +import System.TypeCheck.IO as IO exposing (IO) +import Utils.Main as Utils + + + +-- UNIFY + + +type Answer + = AnswerOk (List IO.Variable) + | AnswerErr (List IO.Variable) Error.Type Error.Type + + +unify : IO.Variable -> IO.Variable -> IO Answer +unify v1 v2 = + case guardedUnify v1 v2 of + Unify k -> + k [] + |> IO.bind + (\result -> + case result of + Ok (UnifyOk vars ()) -> + onSuccess vars () + + Err (UnifyErr vars ()) -> + Type.toErrorType v1 + |> IO.bind + (\t1 -> + Type.toErrorType v2 + |> IO.bind + (\t2 -> + UF.union v1 v2 errorDescriptor + |> IO.fmap (\_ -> AnswerErr vars t1 t2) + ) + ) + ) + + +onSuccess : List IO.Variable -> () -> IO Answer +onSuccess vars () = + IO.pure (AnswerOk vars) + + +errorDescriptor : IO.Descriptor +errorDescriptor = + IO.Descriptor IO.Error Type.noRank Type.noMark Nothing + + + +-- CPS UNIFIER + + +type Unify a + = Unify (List IO.Variable -> IO (Result UnifyErr (UnifyOk a))) + + +type UnifyOk a + = UnifyOk (List IO.Variable) a + + +type UnifyErr + = UnifyErr (List IO.Variable) () + + +fmap : (a -> b) -> Unify a -> Unify b +fmap func (Unify kv) = + Unify <| + \vars -> + IO.fmap + (Result.map + (\(UnifyOk vars1 value) -> + UnifyOk vars1 (func value) + ) + ) + (kv vars) + + +pure : a -> Unify a +pure a = + Unify (\vars -> IO.pure (Ok (UnifyOk vars a))) + + +bind : (a -> Unify b) -> Unify a -> Unify b +bind callback (Unify ka) = + Unify <| + \vars -> + IO.bind + (\result -> + case result of + Ok (UnifyOk vars1 a) -> + case callback a of + Unify kb -> + kb vars1 + + Err err -> + IO.pure (Err err) + ) + (ka vars) + + +register : IO IO.Variable -> Unify IO.Variable +register mkVar = + Unify + (\vars -> + IO.fmap + (\var -> + Ok (UnifyOk (var :: vars) var) + ) + mkVar + ) + + +mismatch : Unify a +mismatch = + Unify (\vars -> IO.pure (Err (UnifyErr vars ()))) + + + +-- UNIFICATION HELPERS + + +type Context + = Context IO.Variable IO.Descriptor IO.Variable IO.Descriptor + + +reorient : Context -> Context +reorient (Context var1 desc1 var2 desc2) = + Context var2 desc2 var1 desc1 + + + +-- MERGE +-- merge : Context -> UF.Content -> Unify ( UF.Point UF.Descriptor, UF.Point UF.Descriptor ) + + +merge : Context -> IO.Content -> Unify () +merge (Context var1 (IO.Descriptor _ rank1 _ _) var2 (IO.Descriptor _ rank2 _ _)) content = + Unify + (\vars -> + UF.union var1 var2 (IO.Descriptor content (min rank1 rank2) Type.noMark Nothing) + |> IO.fmap (Ok << UnifyOk vars) + ) + + +fresh : Context -> IO.Content -> Unify IO.Variable +fresh (Context _ (IO.Descriptor _ rank1 _ _) _ (IO.Descriptor _ rank2 _ _)) content = + register <| + UF.fresh <| + IO.Descriptor content (min rank1 rank2) Type.noMark Nothing + + + +-- ACTUALLY UNIFY THINGS + + +guardedUnify : IO.Variable -> IO.Variable -> Unify () +guardedUnify left right = + Unify + (\vars -> + UF.equivalent left right + |> IO.bind + (\equivalent -> + if equivalent then + IO.pure (Ok (UnifyOk vars ())) + + else + UF.get left + |> IO.bind + (\leftDesc -> + UF.get right + |> IO.bind + (\rightDesc -> + case actuallyUnify (Context left leftDesc right rightDesc) of + Unify k -> + k vars + ) + ) + ) + ) + + +subUnify : IO.Variable -> IO.Variable -> Unify () +subUnify var1 var2 = + guardedUnify var1 var2 + + +subUnifyTuple : List IO.Variable -> List IO.Variable -> Context -> IO.Content -> Unify () +subUnifyTuple cs zs context otherContent = + case ( cs, zs ) of + ( [], [] ) -> + merge context otherContent + + ( c :: restCs, z :: restZs ) -> + subUnify c z + |> bind (\_ -> subUnifyTuple restCs restZs context otherContent) + + _ -> + mismatch + + +actuallyUnify : Context -> Unify () +actuallyUnify ((Context _ (IO.Descriptor firstContent _ _ _) _ (IO.Descriptor secondContent _ _ _)) as context) = + case firstContent of + IO.FlexVar _ -> + unifyFlex context firstContent secondContent + + IO.FlexSuper super _ -> + unifyFlexSuper context super firstContent secondContent + + IO.RigidVar _ -> + unifyRigid context Nothing firstContent secondContent + + IO.RigidSuper super _ -> + unifyRigid context (Just super) firstContent secondContent + + IO.Alias home name args realVar -> + unifyAlias context home name args realVar secondContent + + IO.Structure flatType -> + unifyStructure context flatType firstContent secondContent + + IO.Error -> + -- If there was an error, just pretend it is okay. This lets us avoid + -- "cascading" errors where one problem manifests as multiple message. + merge context IO.Error + + + +-- UNIFY FLEXIBLE VARIABLES + + +unifyFlex : Context -> IO.Content -> IO.Content -> Unify () +unifyFlex context content otherContent = + case otherContent of + IO.Error -> + merge context IO.Error + + IO.FlexVar maybeName -> + merge context <| + case maybeName of + Nothing -> + content + + Just _ -> + otherContent + + IO.FlexSuper _ _ -> + merge context otherContent + + IO.RigidVar _ -> + merge context otherContent + + IO.RigidSuper _ _ -> + merge context otherContent + + IO.Alias _ _ _ _ -> + merge context otherContent + + IO.Structure _ -> + merge context otherContent + + + +-- UNIFY RIGID VARIABLES + + +unifyRigid : Context -> Maybe IO.SuperType -> IO.Content -> IO.Content -> Unify () +unifyRigid context maybeSuper content otherContent = + case otherContent of + IO.FlexVar _ -> + merge context content + + IO.FlexSuper otherSuper _ -> + case maybeSuper of + Just super -> + if combineRigidSupers super otherSuper then + merge context content + + else + mismatch + + Nothing -> + mismatch + + IO.RigidVar _ -> + mismatch + + IO.RigidSuper _ _ -> + mismatch + + IO.Alias _ _ _ _ -> + mismatch + + IO.Structure _ -> + mismatch + + IO.Error -> + merge context IO.Error + + + +-- UNIFY SUPER VARIABLES + + +unifyFlexSuper : Context -> IO.SuperType -> IO.Content -> IO.Content -> Unify () +unifyFlexSuper ((Context first _ _ _) as context) super content otherContent = + case otherContent of + IO.Structure flatType -> + unifyFlexSuperStructure context super flatType + + IO.RigidVar _ -> + mismatch + + IO.RigidSuper otherSuper _ -> + if combineRigidSupers otherSuper super then + merge context otherContent + + else + mismatch + + IO.FlexVar _ -> + merge context content + + IO.FlexSuper otherSuper _ -> + case super of + IO.Number -> + case otherSuper of + IO.Number -> + merge context content + + IO.Comparable -> + merge context content + + IO.Appendable -> + mismatch + + IO.CompAppend -> + mismatch + + IO.Comparable -> + case otherSuper of + IO.Comparable -> + merge context otherContent + + IO.Number -> + merge context otherContent + + IO.Appendable -> + merge context <| Type.unnamedFlexSuper IO.CompAppend + + IO.CompAppend -> + merge context otherContent + + IO.Appendable -> + case otherSuper of + IO.Appendable -> + merge context otherContent + + IO.Comparable -> + merge context <| Type.unnamedFlexSuper IO.CompAppend + + IO.CompAppend -> + merge context otherContent + + IO.Number -> + mismatch + + IO.CompAppend -> + case otherSuper of + IO.Comparable -> + merge context content + + IO.Appendable -> + merge context content + + IO.CompAppend -> + merge context content + + IO.Number -> + mismatch + + IO.Alias _ _ _ realVar -> + subUnify first realVar + + IO.Error -> + merge context IO.Error + + +combineRigidSupers : IO.SuperType -> IO.SuperType -> Bool +combineRigidSupers rigid flex = + rigid + == flex + || (rigid == IO.Number && flex == IO.Comparable) + || (rigid == IO.CompAppend && (flex == IO.Comparable || flex == IO.Appendable)) + + +atomMatchesSuper : IO.SuperType -> IO.Canonical -> Name.Name -> Bool +atomMatchesSuper super home name = + case super of + IO.Number -> + isNumber home name + + IO.Comparable -> + isNumber home name || Error.isString home name || Error.isChar home name + + IO.Appendable -> + Error.isString home name + + IO.CompAppend -> + Error.isString home name + + +isNumber : IO.Canonical -> Name.Name -> Bool +isNumber home name = + (home == ModuleName.basics) + && (name == Name.int || name == Name.float) + + +unifyFlexSuperStructure : Context -> IO.SuperType -> IO.FlatType -> Unify () +unifyFlexSuperStructure context super flatType = + case flatType of + IO.App1 home name [] -> + if atomMatchesSuper super home name then + merge context (IO.Structure flatType) + + else + mismatch + + IO.App1 home name [ variable ] -> + if home == ModuleName.list && name == Name.list then + case super of + IO.Number -> + mismatch + + IO.Appendable -> + merge context (IO.Structure flatType) + + IO.Comparable -> + comparableOccursCheck context + |> bind (\_ -> unifyComparableRecursive variable) + |> bind (\_ -> merge context (IO.Structure flatType)) + + IO.CompAppend -> + comparableOccursCheck context + |> bind (\_ -> unifyComparableRecursive variable) + |> bind (\_ -> merge context (IO.Structure flatType)) + + else + mismatch + + IO.Tuple1 a b cs -> + case super of + IO.Number -> + mismatch + + IO.Appendable -> + mismatch + + IO.Comparable -> + List.foldl (\var _ -> unifyComparableRecursive var) (comparableOccursCheck context) (a :: b :: cs) + |> bind (\_ -> merge context (IO.Structure flatType)) + + IO.CompAppend -> + mismatch + + _ -> + mismatch + + + +-- TODO: is there some way to avoid doing this? +-- Do type classes require occurs checks? + + +comparableOccursCheck : Context -> Unify () +comparableOccursCheck (Context _ _ var _) = + Unify + (\vars -> + Occurs.occurs var + |> IO.fmap + (\hasOccurred -> + if hasOccurred then + Err (UnifyErr vars ()) + + else + Ok (UnifyOk vars ()) + ) + ) + + +unifyComparableRecursive : IO.Variable -> Unify () +unifyComparableRecursive var = + register + (UF.get var + |> IO.bind + (\(IO.Descriptor _ rank _ _) -> + UF.fresh (IO.Descriptor (Type.unnamedFlexSuper IO.Comparable) rank Type.noMark Nothing) + ) + ) + |> bind (\compVar -> guardedUnify compVar var) + + + +-- UNIFY ALIASES + + +unifyAlias : Context -> IO.Canonical -> Name.Name -> List ( Name.Name, IO.Variable ) -> IO.Variable -> IO.Content -> Unify () +unifyAlias ((Context _ _ second _) as context) home name args realVar otherContent = + case otherContent of + IO.FlexVar _ -> + merge context (IO.Alias home name args realVar) + + IO.FlexSuper _ _ -> + subUnify realVar second + + IO.RigidVar _ -> + subUnify realVar second + + IO.RigidSuper _ _ -> + subUnify realVar second + + IO.Alias otherHome otherName otherArgs otherRealVar -> + if name == otherName && home == otherHome then + Unify + (\vars -> + unifyAliasArgs vars args otherArgs + |> IO.bind + (\res -> + case res of + Ok (UnifyOk vars1 ()) -> + case merge context otherContent of + Unify k -> + k vars1 + + Err err -> + IO.pure (Err err) + ) + ) + + else + subUnify realVar otherRealVar + + IO.Structure _ -> + subUnify realVar second + + IO.Error -> + merge context IO.Error + + +unifyAliasArgs : List IO.Variable -> List ( Name.Name, IO.Variable ) -> List ( Name.Name, IO.Variable ) -> IO (Result UnifyErr (UnifyOk ())) +unifyAliasArgs vars args1 args2 = + case args1 of + ( _, arg1 ) :: others1 -> + case args2 of + ( _, arg2 ) :: others2 -> + case subUnify arg1 arg2 of + Unify k -> + k vars + |> IO.bind + (\res1 -> + case res1 of + Ok (UnifyOk vs ()) -> + unifyAliasArgs vs others1 others2 + + Err (UnifyErr vs ()) -> + unifyAliasArgs vs others1 others2 + |> IO.fmap + (\res2 -> + case res2 of + Ok (UnifyOk vs_ ()) -> + Err (UnifyErr vs_ ()) + + Err err -> + Err err + ) + ) + + _ -> + IO.pure (Err (UnifyErr vars ())) + + [] -> + case args2 of + [] -> + IO.pure (Ok (UnifyOk vars ())) + + _ -> + IO.pure (Err (UnifyErr vars ())) + + + +-- UNIFY STRUCTURES + + +unifyStructure : Context -> IO.FlatType -> IO.Content -> IO.Content -> Unify () +unifyStructure ((Context first _ second _) as context) flatType content otherContent = + case otherContent of + IO.FlexVar _ -> + merge context content + + IO.FlexSuper super _ -> + unifyFlexSuperStructure (reorient context) super flatType + + IO.RigidVar _ -> + mismatch + + IO.RigidSuper _ _ -> + mismatch + + IO.Alias _ _ _ realVar -> + subUnify first realVar + + IO.Structure otherFlatType -> + case ( flatType, otherFlatType ) of + ( IO.App1 home name args, IO.App1 otherHome otherName otherArgs ) -> + if home == otherHome && name == otherName then + Unify + (\vars -> + unifyArgs vars args otherArgs + |> IO.bind + (\unifiedArgs -> + case unifiedArgs of + Ok (UnifyOk vars1 ()) -> + case merge context otherContent of + Unify k -> + k vars1 + + Err err -> + IO.pure (Err err) + ) + ) + + else + mismatch + + ( IO.Fun1 arg1 res1, IO.Fun1 arg2 res2 ) -> + subUnify arg1 arg2 + |> bind (\_ -> subUnify res1 res2) + |> bind (\_ -> merge context otherContent) + + ( IO.EmptyRecord1, IO.EmptyRecord1 ) -> + merge context otherContent + + ( IO.Record1 fields ext, IO.EmptyRecord1 ) -> + if Dict.isEmpty fields then + subUnify ext second + + else + mismatch + + ( IO.EmptyRecord1, IO.Record1 fields ext ) -> + if Dict.isEmpty fields then + subUnify first ext + + else + mismatch + + ( IO.Record1 fields1 ext1, IO.Record1 fields2 ext2 ) -> + Unify + (\vars -> + gatherFields fields1 ext1 + |> IO.bind + (\structure1 -> + gatherFields fields2 ext2 + |> IO.bind + (\structure2 -> + case unifyRecord context structure1 structure2 of + Unify k -> + k vars + ) + ) + ) + + ( IO.Tuple1 a b cs, IO.Tuple1 x y zs ) -> + subUnify a x + |> bind (\_ -> subUnify b y) + |> bind (\_ -> subUnifyTuple cs zs context otherContent) + + ( IO.Unit1, IO.Unit1 ) -> + merge context otherContent + + _ -> + mismatch + + IO.Error -> + merge context IO.Error + + + +-- UNIFY ARGS + + +unifyArgs : List IO.Variable -> List IO.Variable -> List IO.Variable -> IO (Result UnifyErr (UnifyOk ())) +unifyArgs vars args1 args2 = + case args1 of + arg1 :: others1 -> + case args2 of + arg2 :: others2 -> + case subUnify arg1 arg2 of + Unify k -> + k vars + |> IO.bind + (\result -> + case result of + Ok (UnifyOk vs ()) -> + unifyArgs vs others1 others2 + + Err (UnifyErr vs ()) -> + unifyArgs vs others1 others2 + |> IO.fmap + (Result.andThen + (\(UnifyOk vs_ ()) -> + Err (UnifyErr vs_ ()) + ) + ) + ) + + _ -> + IO.pure (Err (UnifyErr vars ())) + + [] -> + case args2 of + [] -> + IO.pure (Ok (UnifyOk vars ())) + + _ -> + IO.pure (Err (UnifyErr vars ())) + + + +-- UNIFY RECORDS + + +unifyRecord : Context -> RecordStructure -> RecordStructure -> Unify () +unifyRecord context (RecordStructure fields1 ext1) (RecordStructure fields2 ext2) = + let + sharedFields : Dict String Name.Name ( IO.Variable, IO.Variable ) + sharedFields = + Utils.mapIntersectionWith identity compare Tuple.pair fields1 fields2 + + uniqueFields1 : Dict String Name.Name IO.Variable + uniqueFields1 = + Dict.diff fields1 fields2 + + uniqueFields2 : Dict String Name.Name IO.Variable + uniqueFields2 = + Dict.diff fields2 fields1 + in + if Dict.isEmpty uniqueFields1 then + if Dict.isEmpty uniqueFields2 then + subUnify ext1 ext2 + |> bind (\_ -> unifySharedFields context sharedFields Dict.empty ext1) + + else + fresh context (IO.Structure (IO.Record1 uniqueFields2 ext2)) + |> bind + (\subRecord -> + subUnify ext1 subRecord + |> bind (\_ -> unifySharedFields context sharedFields Dict.empty subRecord) + ) + + else if Dict.isEmpty uniqueFields2 then + fresh context (IO.Structure (IO.Record1 uniqueFields1 ext1)) + |> bind + (\subRecord -> + subUnify subRecord ext2 + |> bind (\_ -> unifySharedFields context sharedFields Dict.empty subRecord) + ) + + else + let + otherFields : Dict String Name.Name IO.Variable + otherFields = + Dict.union uniqueFields1 uniqueFields2 + in + fresh context Type.unnamedFlexVar + |> bind + (\ext -> + fresh context (IO.Structure (IO.Record1 uniqueFields1 ext)) + |> bind + (\sub1 -> + fresh context (IO.Structure (IO.Record1 uniqueFields2 ext)) + |> bind + (\sub2 -> + subUnify ext1 sub2 + |> bind (\_ -> subUnify sub1 ext2) + |> bind (\_ -> unifySharedFields context sharedFields otherFields ext) + ) + ) + ) + + +unifySharedFields : Context -> Dict String Name.Name ( IO.Variable, IO.Variable ) -> Dict String Name.Name IO.Variable -> IO.Variable -> Unify () +unifySharedFields context sharedFields otherFields ext = + traverseMaybe identity compare unifyField sharedFields + |> bind + (\matchingFields -> + if Dict.size sharedFields == Dict.size matchingFields then + merge context (IO.Structure (IO.Record1 (Dict.union matchingFields otherFields) ext)) + + else + mismatch + ) + + +traverseMaybe : (a -> comparable) -> (a -> a -> Order) -> (a -> b -> Unify (Maybe c)) -> Dict comparable a b -> Unify (Dict comparable a c) +traverseMaybe toComparable keyComparison func = + Dict.foldl keyComparison + (\a b -> + bind + (\acc -> + fmap + (\maybeC -> + maybeC + |> Maybe.map (\c -> Dict.insert toComparable a c acc) + |> Maybe.withDefault acc + ) + (func a b) + ) + ) + (pure Dict.empty) + + +unifyField : Name.Name -> ( IO.Variable, IO.Variable ) -> Unify (Maybe IO.Variable) +unifyField _ ( actual, expected ) = + Unify + (\vars -> + case subUnify actual expected of + Unify k -> + k vars + |> IO.fmap + (\result -> + case result of + Ok (UnifyOk vs ()) -> + Ok (UnifyOk vs (Just actual)) + + Err (UnifyErr vs ()) -> + Ok (UnifyOk vs Nothing) + ) + ) + + + +-- GATHER RECORD STRUCTURE + + +type RecordStructure + = RecordStructure (Dict String Name.Name IO.Variable) IO.Variable + + +gatherFields : Dict String Name.Name IO.Variable -> IO.Variable -> IO RecordStructure +gatherFields fields variable = + UF.get variable + |> IO.bind + (\(IO.Descriptor content _ _ _) -> + case content of + IO.Structure (IO.Record1 subFields subExt) -> + gatherFields (Dict.union fields subFields) subExt + + IO.Alias _ _ _ var -> + -- TODO may be dropping useful alias info here + gatherFields fields var + + _ -> + IO.pure (RecordStructure fields variable) + ) diff --git a/src/Compiler/Type/UnionFind.elm b/src/Compiler/Type/UnionFind.elm new file mode 100644 index 0000000000..db1a7dc9ea --- /dev/null +++ b/src/Compiler/Type/UnionFind.elm @@ -0,0 +1,218 @@ +module Compiler.Type.UnionFind exposing + ( equivalent + , fresh + , get + , modify + , redundant + , set + , union + ) + +{- This is based on the following implementations: + + - https://hackage.haskell.org/package/union-find-0.2/docs/src/Data-UnionFind-IO.html + - http://yann.regis-gianas.org/public/mini/code_UnionFind.html + + It seems like the OCaml one came first, but I am not sure. + + Compared to the Haskell implementation, the major changes here include: + + 1. No more reallocating PointInfo when changing the weight + 2. Using the strict modifyIORef + +-} + +import Data.IORef as IORef exposing (IORef(..)) +import System.TypeCheck.IO as IO exposing (Descriptor, IO) +import Utils.Crash exposing (crash) + + + +-- HELPERS + + +fresh : IO.Descriptor -> IO IO.Point +fresh value = + IORef.newIORefWeight 1 + |> IO.bind + (\(IORef weight) -> + IORef.newIORefDescriptor value + |> IO.bind (\(IORef desc) -> IORef.newIORefPointInfo (IO.Info weight desc)) + |> IO.fmap (\(IORef link) -> IO.Pt link) + ) + + +repr : IO.Point -> IO IO.Point +repr ((IO.Pt ref) as point) = + IORef.readIORefPointInfo (IORef ref) + |> IO.bind + (\pInfo -> + case pInfo of + IO.Info _ _ -> + IO.pure point + + IO.Link ((IO.Pt ref1) as point1) -> + repr point1 + |> IO.bind + (\point2 -> + if point2 /= point1 then + IORef.readIORefPointInfo (IORef ref1) + |> IO.bind + (\pInfo1 -> + IORef.writeIORefPointInfo (IORef ref) pInfo1 + |> IO.fmap (\_ -> point2) + ) + + else + IO.pure point2 + ) + ) + + +get : IO.Point -> IO Descriptor +get ((IO.Pt ref) as point) = + IORef.readIORefPointInfo (IORef ref) + |> IO.bind + (\pInfo -> + case pInfo of + IO.Info _ descRef -> + IORef.readIORefDescriptor (IORef descRef) + + IO.Link (IO.Pt ref1) -> + IORef.readIORefPointInfo (IORef ref1) + |> IO.bind + (\link_ -> + case link_ of + IO.Info _ descRef -> + IORef.readIORefDescriptor (IORef descRef) + + IO.Link _ -> + IO.bind get (repr point) + ) + ) + + +set : IO.Point -> Descriptor -> IO () +set ((IO.Pt ref) as point) newDesc = + IORef.readIORefPointInfo (IORef ref) + |> IO.bind + (\pInfo -> + case pInfo of + IO.Info _ descRef -> + IORef.writeIORefDescriptor (IORef descRef) newDesc + + IO.Link (IO.Pt ref1) -> + IORef.readIORefPointInfo (IORef ref1) + |> IO.bind + (\link_ -> + case link_ of + IO.Info _ descRef -> + IORef.writeIORefDescriptor (IORef descRef) newDesc + + IO.Link _ -> + repr point + |> IO.bind + (\newPoint -> + set newPoint newDesc + ) + ) + ) + + +modify : IO.Point -> (Descriptor -> Descriptor) -> IO () +modify ((IO.Pt ref) as point) func = + IORef.readIORefPointInfo (IORef ref) + |> IO.bind + (\pInfo -> + case pInfo of + IO.Info _ descRef -> + IORef.modifyIORefDescriptor (IORef descRef) func + + IO.Link (IO.Pt ref1) -> + IORef.readIORefPointInfo (IORef ref1) + |> IO.bind + (\link_ -> + case link_ of + IO.Info _ descRef -> + IORef.modifyIORefDescriptor (IORef descRef) func + + IO.Link _ -> + repr point + |> IO.bind (\newPoint -> modify newPoint func) + ) + ) + + +union : IO.Point -> IO.Point -> IO.Descriptor -> IO () +union p1 p2 newDesc = + repr p1 + |> IO.bind + (\((IO.Pt ref1) as point1) -> + repr p2 + |> IO.bind + (\((IO.Pt ref2) as point2) -> + IORef.readIORefPointInfo (IORef ref1) + |> IO.bind + (\pointInfo1 -> + IORef.readIORefPointInfo (IORef ref2) + |> IO.bind + (\pointInfo2 -> + case ( pointInfo1, pointInfo2 ) of + ( IO.Info w1 d1, IO.Info w2 d2 ) -> + if point1 == point2 then + IORef.writeIORefDescriptor (IORef d1) newDesc + + else + IORef.readIORefWeight (IORef w1) + |> IO.bind + (\weight1 -> + IORef.readIORefWeight (IORef w2) + |> IO.bind + (\weight2 -> + let + newWeight : Int + newWeight = + weight1 + weight2 + in + if weight1 >= weight2 then + IORef.writeIORefPointInfo (IORef ref2) (IO.Link point1) + |> IO.bind (\_ -> IORef.writeIORefWeight (IORef w1) newWeight) + |> IO.bind (\_ -> IORef.writeIORefDescriptor (IORef d1) newDesc) + + else + IORef.writeIORefPointInfo (IORef ref1) (IO.Link point2) + |> IO.bind (\_ -> IORef.writeIORefWeight (IORef w2) newWeight) + |> IO.bind (\_ -> IORef.writeIORefDescriptor (IORef d2) newDesc) + ) + ) + + _ -> + crash "Unexpected pattern" + ) + ) + ) + ) + + +equivalent : IO.Point -> IO.Point -> IO Bool +equivalent p1 p2 = + repr p1 + |> IO.bind + (\v1 -> + repr p2 + |> IO.fmap (\v2 -> v1 == v2) + ) + + +redundant : IO.Point -> IO Bool +redundant (IO.Pt ref) = + IORef.readIORefPointInfo (IORef ref) + |> IO.fmap + (\pInfo -> + case pInfo of + IO.Info _ _ -> + False + + IO.Link _ -> + True + ) diff --git a/src/Control/Monad/State/Strict.elm b/src/Control/Monad/State/Strict.elm new file mode 100644 index 0000000000..ceb45330be --- /dev/null +++ b/src/Control/Monad/State/Strict.elm @@ -0,0 +1,98 @@ +module Control.Monad.State.Strict exposing + ( StateT(..) + , evalStateT + , fmap + , get + , liftIO + , put + ) + +{-| Lazy state monads, passing an updatable state through a computation. +-} + +import Json.Decode as Decode +import Json.Encode as Encode +import System.IO as IO +import Task exposing (Task) +import Utils.Impure as Impure +import Utils.Task.Extra as Task + + +{-| newtype StateT s m a + +A state transformer monad parameterized by: + +s - The state. +m - The inner monad. (== IO) + +The return function leaves the state unchanged, while >>= uses the final state of the first computation as the initial state of the second. + +Ref.: + +-} +type StateT s a + = StateT (s -> Task Never ( a, s )) + + +evalStateT : StateT s a -> s -> Task Never a +evalStateT (StateT f) = + f >> Task.fmap Tuple.first + + +liftIO : Task Never a -> StateT s a +liftIO io = + StateT (\s -> Task.fmap (\a -> ( a, s )) io) + + +apply : StateT s a -> StateT s (a -> b) -> StateT s b +apply (StateT arg) (StateT func) = + StateT + (\s -> + arg s + |> Task.bind + (\( a, sa ) -> + func sa + |> Task.fmap (\( fb, sb ) -> ( fb a, sb )) + ) + ) + + +fmap : (a -> b) -> StateT s a -> StateT s b +fmap func argStateT = + apply argStateT (pure func) + + +pure : a -> StateT s a +pure value = + StateT (\s -> Task.pure ( value, s )) + + +get : StateT s IO.ReplState +get = + liftIO + (Impure.task "getStateT" + [] + Impure.EmptyBody + (Impure.DecoderResolver + (Decode.map3 (\imports types decls -> IO.ReplState imports types decls) + (Decode.field "imports" (Decode.dict Decode.string)) + (Decode.field "types" (Decode.dict Decode.string)) + (Decode.field "decls" (Decode.dict Decode.string)) + ) + ) + ) + + +put : IO.ReplState -> Task Never () +put (IO.ReplState imports types decls) = + Impure.task "putStateT" + [] + (Impure.JsonBody + (Encode.object + [ ( "imports", Encode.dict identity Encode.string imports ) + , ( "types", Encode.dict identity Encode.string types ) + , ( "decls", Encode.dict identity Encode.string decls ) + ] + ) + ) + (Impure.Always ()) diff --git a/src/Control/Monad/State/TypeCheck/Strict.elm b/src/Control/Monad/State/TypeCheck/Strict.elm new file mode 100644 index 0000000000..103033d367 --- /dev/null +++ b/src/Control/Monad/State/TypeCheck/Strict.elm @@ -0,0 +1,133 @@ +module Control.Monad.State.TypeCheck.Strict exposing + ( StateT(..) + , apply + , bind + , evalStateT + , fmap + , gets + , liftIO + , modify + , pure + , runStateT + , traverseList + , traverseMap + , traverseMaybe + , traverseTuple + ) + +{-| Lazy state monads, passing an updatable state through a computation. +-} + +import Data.Map as Dict exposing (Dict) +import System.TypeCheck.IO as IO exposing (IO) + + +{-| newtype StateT s m a + +A state transformer monad parameterized by: + +s - The state. +m - The inner monad. (== IO) + +The return function leaves the state unchanged, while >>= uses the final state of the first computation as the initial state of the second. + +Ref.: + +-} +type StateT s a + = StateT (s -> IO ( a, s )) + + +runStateT : StateT s a -> s -> IO ( a, s ) +runStateT (StateT f) = + f + + +evalStateT : StateT s a -> s -> IO a +evalStateT (StateT f) = + f >> IO.fmap Tuple.first + + +liftIO : IO a -> StateT s a +liftIO io = + StateT (\s -> IO.fmap (\a -> ( a, s )) io) + + +apply : StateT s a -> StateT s (a -> b) -> StateT s b +apply (StateT arg) (StateT func) = + StateT + (\s -> + arg s + |> IO.bind + (\( a, sa ) -> + func sa + |> IO.fmap (\( fb, sb ) -> ( fb a, sb )) + ) + ) + + +fmap : (a -> b) -> StateT s a -> StateT s b +fmap func argStateT = + apply argStateT (pure func) + + +bind : (a -> StateT s b) -> StateT s a -> StateT s b +bind func (StateT arg) = + StateT + (\s -> + arg s + |> IO.bind + (\( a, sa ) -> + case func a of + StateT fb -> + fb sa + ) + ) + + +pure : a -> StateT s a +pure value = + StateT (\s -> IO.pure ( value, s )) + + +gets : (s -> a) -> StateT s a +gets f = + StateT (\s -> IO.pure ( f s, s )) + + +modify : (s -> s) -> StateT s () +modify f = + StateT (\s -> IO.pure ( (), f s )) + + +traverseList : (a -> StateT s b) -> List a -> StateT s (List b) +traverseList f = + List.foldr (\a -> bind (\c -> fmap (\va -> va :: c) (f a))) + (pure []) + + +traverseTuple : (b -> StateT s c) -> ( a, b ) -> StateT s ( a, c ) +traverseTuple f ( a, b ) = + fmap (Tuple.pair a) (f b) + + +traverseMap : (k -> k -> Order) -> (k -> comparable) -> (a -> StateT s b) -> Dict comparable k a -> StateT s (Dict comparable k b) +traverseMap keyComparison toComparable f = + traverseMapWithKey keyComparison toComparable (\_ -> f) + + +traverseMapWithKey : (k -> k -> Order) -> (k -> comparable) -> (k -> a -> StateT s b) -> Dict comparable k a -> StateT s (Dict comparable k b) +traverseMapWithKey keyComparison toComparable f = + Dict.foldl keyComparison + (\k a -> bind (\c -> fmap (\va -> Dict.insert toComparable k va c) (f k a))) + (pure Dict.empty) + + +traverseMaybe : (a -> StateT s b) -> Maybe a -> StateT s (Maybe b) +traverseMaybe f a = + case Maybe.map f a of + Just b -> + fmap Just b + + Nothing -> + pure Nothing diff --git a/src/Data/IORef.elm b/src/Data/IORef.elm new file mode 100644 index 0000000000..fdcaeaa088 --- /dev/null +++ b/src/Data/IORef.elm @@ -0,0 +1,121 @@ +module Data.IORef exposing + ( IORef(..) + , modifyIORefDescriptor + , modifyIORefMVector + , newIORefDescriptor + , newIORefMVector + , newIORefPointInfo + , newIORefWeight + , readIORefDescriptor + , readIORefMVector + , readIORefPointInfo + , readIORefWeight + , writeIORefDescriptor + , writeIORefMVector + , writeIORefPointInfo + , writeIORefWeight + ) + +import Array exposing (Array) +import System.TypeCheck.IO as IO exposing (IO) +import Utils.Crash exposing (crash) + + +type IORef a + = IORef Int + + +newIORefWeight : Int -> IO (IORef Int) +newIORefWeight value = + \s -> ( { s | ioRefsWeight = Array.push value s.ioRefsWeight }, IORef (Array.length s.ioRefsWeight) ) + + +newIORefPointInfo : IO.PointInfo -> IO (IORef IO.PointInfo) +newIORefPointInfo value = + \s -> ( { s | ioRefsPointInfo = Array.push value s.ioRefsPointInfo }, IORef (Array.length s.ioRefsPointInfo) ) + + +newIORefDescriptor : IO.Descriptor -> IO (IORef IO.Descriptor) +newIORefDescriptor value = + \s -> ( { s | ioRefsDescriptor = Array.push value s.ioRefsDescriptor }, IORef (Array.length s.ioRefsDescriptor) ) + + +newIORefMVector : Array (Maybe (List IO.Variable)) -> IO (IORef (Array (Maybe (List IO.Variable)))) +newIORefMVector value = + \s -> ( { s | ioRefsMVector = Array.push value s.ioRefsMVector }, IORef (Array.length s.ioRefsMVector) ) + + +readIORefWeight : IORef Int -> IO Int +readIORefWeight (IORef ref) = + \s -> + case Array.get ref s.ioRefsWeight of + Just value -> + ( s, value ) + + Nothing -> + crash "Data.IORef.readIORefWeight: could not find entry" + + +readIORefPointInfo : IORef IO.PointInfo -> IO IO.PointInfo +readIORefPointInfo (IORef ref) = + \s -> + case Array.get ref s.ioRefsPointInfo of + Just value -> + ( s, value ) + + Nothing -> + crash "Data.IORef.readIORefPointInfo: could not find entry" + + +readIORefDescriptor : IORef IO.Descriptor -> IO IO.Descriptor +readIORefDescriptor (IORef ref) = + \s -> + case Array.get ref s.ioRefsDescriptor of + Just value -> + ( s, value ) + + Nothing -> + crash "Data.IORef.readIORefDescriptor: could not find entry" + + +readIORefMVector : IORef (Array (Maybe (List IO.Variable))) -> IO (Array (Maybe (List IO.Variable))) +readIORefMVector (IORef ref) = + \s -> + case Array.get ref s.ioRefsMVector of + Just value -> + ( s, value ) + + Nothing -> + crash "Data.IORef.readIORefMVector: could not find entry" + + +writeIORefWeight : IORef Int -> Int -> IO () +writeIORefWeight (IORef ref) value = + \s -> ( { s | ioRefsWeight = Array.set ref value s.ioRefsWeight }, () ) + + +writeIORefPointInfo : IORef IO.PointInfo -> IO.PointInfo -> IO () +writeIORefPointInfo (IORef ref) value = + \s -> ( { s | ioRefsPointInfo = Array.set ref value s.ioRefsPointInfo }, () ) + + +writeIORefDescriptor : IORef IO.Descriptor -> IO.Descriptor -> IO () +writeIORefDescriptor (IORef ref) value = + \s -> ( { s | ioRefsDescriptor = Array.set ref value s.ioRefsDescriptor }, () ) + + +writeIORefMVector : IORef (Array (Maybe (List IO.Variable))) -> Array (Maybe (List IO.Variable)) -> IO () +writeIORefMVector (IORef ref) value = + \s -> ( { s | ioRefsMVector = Array.set ref value s.ioRefsMVector }, () ) + + +modifyIORefDescriptor : IORef IO.Descriptor -> (IO.Descriptor -> IO.Descriptor) -> IO () +modifyIORefDescriptor ioRef func = + readIORefDescriptor ioRef + |> IO.bind (\value -> writeIORefDescriptor ioRef (func value)) + + +modifyIORefMVector : IORef (Array (Maybe (List IO.Variable))) -> (Array (Maybe (List IO.Variable)) -> Array (Maybe (List IO.Variable))) -> IO () +modifyIORefMVector ioRef func = + readIORefMVector ioRef + |> IO.bind (\value -> writeIORefMVector ioRef (func value)) diff --git a/src/Data/Map.elm b/src/Data/Map.elm new file mode 100644 index 0000000000..1c4a8a23a5 --- /dev/null +++ b/src/Data/Map.elm @@ -0,0 +1,418 @@ +module Data.Map exposing + ( Dict + , empty, singleton, insert, update, remove + , isEmpty, member, get, size, eq + , keys, values, toList, fromList + , map, foldl, foldr, filter, partition + , union, intersection, diff, merge + ) + +{-| **Initial implementation from `pzp1997/assoc-list/1.0.0`** + +An [association list](https://en.wikipedia.org/wiki/Association_list) is a +list of tuples that map unique keys to values. The keys can be of any type (so +long as it has a reasonable definition for equality). This includes pretty +much everything except for functions and things that contain functions. + +All functions in this module are "stack safe," which means that your program +won't crash from recursing over large association lists. You can read +Evan Czaplicki's +[document on tail-call elimination](https://github.com/evancz/functional-programming-in-elm/blob/master/recursion/tail-call-elimination.md) +for more information about this topic. + + +# Dictionaries + +@docs Dict + + +# Build + +@docs empty, singleton, insert, update, remove + + +# Query + +@docs isEmpty, member, get, size, eq + + +# Lists + +@docs keys, values, toList, fromList + + +# Transform + +@docs map, foldl, foldr, filter, partition + + +# Combine + +@docs union, intersection, diff, merge + +-} + +import Dict + + +{-| A dictionary of keys and values. So a `Dict String User` is a dictionary +that lets you look up a `String` (such as user names) and find the associated +`User`. + + import Data.Map as Dict exposing (Dict) + + users : Dict String User + users = + Dict.fromList + [ ( "Alice", User "Alice" 28 1.65 ) + , ( "Bob", User "Bob" 19 1.82 ) + , ( "Chuck", User "Chuck" 33 1.75 ) + ] + + type alias User = + { name : String + , age : Int + , height : Float + } + +-} +type Dict c k v + = D (Dict.Dict c ( k, v )) + + +{-| Create an empty dictionary. +-} +empty : Dict c k v +empty = + D Dict.empty + + +{-| Get the value associated with a key. If the key is not found, return +`Nothing`. This is useful when you are not sure if a key will be in the +dictionary. + + type Animal + = Cat + | Mouse + + animals : Dict String Animal + animals = fromList [ ("Tom", Cat), ("Jerry", Mouse) ] + + get "Tom" animals + --> Just Cat + + get "Jerry" animals + --> Just Mouse + + get "Spike" animals + --> Nothing + +-} +get : (k -> comparable) -> k -> Dict comparable k v -> Maybe v +get toComparable targetKey (D dict) = + Dict.get (toComparable targetKey) dict + |> Maybe.map Tuple.second + + +{-| Determine if a key is in a dictionary. +-} +member : (k -> comparable) -> k -> Dict comparable k v -> Bool +member toComparable targetKey (D dict) = + Dict.member (toComparable targetKey) dict + + +{-| Determine the number of key-value pairs in the dictionary. + + size (fromList [ ( "a", 1 ), ( "b", 2 ), ( "c", 3 ) ]) + --> 3 + + size (insert 1 "b" (singleton 1 "a")) + --> 1 + +-} +size : Dict c k v -> Int +size (D dict) = + Dict.size dict + + +{-| Determine if a dictionary is empty. + + isEmpty empty + --> True + +-} +isEmpty : Dict c k v -> Bool +isEmpty (D dict) = + Dict.isEmpty dict + + +{-| Compare two dictionaries for equality, ignoring insertion order. +Dictionaries are defined to be equal when they have identical key-value pairs +where keys and values are compared using the built-in equality operator. + +You should almost never use the built-in equality operator to compare +dictionaries from this module since association lists have no canonical form. + + eq + (fromList [ ( "a", 1 ), ( "b", 2 ) ]) + (fromList [ ( "b", 2 ), ( "a", 1 ) ]) + --> True + +-} +eq : Dict comparable k v -> Dict comparable k v -> Bool +eq leftDict rightDict = + merge (\_ _ -> EQ) + (\_ _ _ -> False) + (\_ a b result -> result && a == b) + (\_ _ _ -> False) + leftDict + rightDict + True + + +{-| Insert a key-value pair into a dictionary. Replaces value when there is +a collision. +-} +insert : (k -> comparable) -> k -> v -> Dict comparable k v -> Dict comparable k v +insert toComparable key value (D dict) = + D (Dict.insert (toComparable key) ( key, value ) dict) + + +{-| Remove a key-value pair from a dictionary. If the key is not found, +no changes are made. +-} +remove : (k -> comparable) -> k -> Dict comparable k v -> Dict comparable k v +remove toComparable targetKey (D dict) = + D (Dict.remove (toComparable targetKey) dict) + + +{-| Update the value of a dictionary for a specific key with a given function. + +If you are using this module as an ordered dictionary, please note that if you +are replacing the value of an existing entry, the entry will remain where it +is in the insertion order. (If you do want to change the insertion order, +consider using `get` in conjunction with `insert` instead.) + +-} +update : (k -> comparable) -> k -> (Maybe v -> Maybe v) -> Dict comparable k v -> Dict comparable k v +update toComparable targetKey alter (D dict) = + D + (Dict.update (toComparable targetKey) + (Maybe.map Tuple.second + >> alter + >> Maybe.map (Tuple.pair targetKey) + ) + dict + ) + + +{-| Create a dictionary with one key-value pair. +-} +singleton : (k -> comparable) -> k -> v -> Dict comparable k v +singleton toComparable key value = + D (Dict.singleton (toComparable key) ( key, value )) + + + +-- COMBINE + + +{-| Combine two dictionaries. If there is a collision, preference is given +to the first dictionary. + +If you are using this module as an ordered dictionary, the ordering of the +output dictionary will be all the entries of the first dictionary (from most +recently inserted to least recently inserted) followed by all the entries of +the second dictionary (from most recently inserted to least recently inserted). + +-} +union : Dict comparable k v -> Dict comparable k v -> Dict comparable k v +union (D leftDict) (D rightDict) = + D (Dict.union leftDict rightDict) + + +{-| Keep a key-value pair when its key appears in the second dictionary. +Preference is given to values in the first dictionary. +-} +intersection : (k -> k -> Order) -> Dict comparable k a -> Dict comparable k b -> Dict comparable k a +intersection keyComparison dict1 dict2 = + let + keys2 : List k + keys2 = + keys keyComparison dict2 + in + filter (\k _ -> List.member k keys2) dict1 + + +{-| Keep a key-value pair when its key does not appear in the second dictionary. +-} +diff : Dict comparable k a -> Dict comparable k b -> Dict comparable k a +diff (D leftDict) (D rightDict) = + D (Dict.diff leftDict rightDict) + + +{-| The most general way of combining two dictionaries. You provide three +accumulators for when a given key appears: + +1. Only in the left dictionary. +2. In both dictionaries. +3. Only in the right dictionary. + +You then traverse all the keys in the following order, building up whatever +you want: + +1. All the keys that appear only in the right dictionary from least + recently inserted to most recently inserted. +2. All the keys in the left dictionary from least recently inserted to most + recently inserted (without regard to whether they appear only in the left + dictionary or in both dictionaries). + +-} +merge : + (k -> k -> Order) + -> (k -> a -> result -> result) + -> (k -> a -> b -> result -> result) + -> (k -> b -> result -> result) + -> Dict comparable k a + -> Dict comparable k b + -> result + -> result +merge _ leftStep bothStep rightStep (D leftDict) (D rightDict) initialResult = + Dict.merge + (\_ ( k, a ) -> leftStep k a) + (\_ ( k, a ) ( _, b ) -> bothStep k a b) + (\_ ( k, b ) -> rightStep k b) + leftDict + rightDict + initialResult + + + +-- TRANSFORM + + +{-| Apply a function to all values in a dictionary. +-} +map : (k -> a -> b) -> Dict c k a -> Dict c k b +map alter (D dict) = + D (Dict.map (\_ ( key, value ) -> ( key, alter key value )) dict) + + +{-| Fold over the key-value pairs in a dictionary from most recently inserted +to least recently inserted. + + users : Dict String Int + users = + empty + |> insert "Alice" 28 + |> insert "Bob" 19 + |> insert "Chuck" 33 + + foldl (\name age result -> age :: result) [] users + --> [28,19,33] + +-} +foldl : (k -> k -> Order) -> (k -> v -> b -> b) -> b -> Dict c k v -> b +foldl keyComparison func initialResult dict = + List.foldl + (\( key, value ) result -> + func key value result + ) + initialResult + (toList keyComparison dict) + + +{-| Fold over the key-value pairs in a dictionary from least recently inserted +to most recently insered. + + users : Dict String Int + users = + empty + |> insert "Alice" 28 + |> insert "Bob" 19 + |> insert "Chuck" 33 + + foldr (\name age result -> age :: result) [] users + --> [33,19,28] + +-} +foldr : (k -> k -> Order) -> (k -> v -> b -> b) -> b -> Dict c k v -> b +foldr keyComparison func initialResult dict = + List.foldr + (\( key, value ) result -> + func key value result + ) + initialResult + (toList keyComparison dict) + + +{-| Keep only the key-value pairs that pass the given test. +-} +filter : (k -> v -> Bool) -> Dict comparable k v -> Dict comparable k v +filter isGood (D dict) = + D (Dict.filter (\_ ( key, value ) -> isGood key value) dict) + + +{-| Partition a dictionary according to some test. The first dictionary +contains all key-value pairs which passed the test, and the second contains +the pairs that did not. +-} +partition : (k -> v -> Bool) -> Dict comparable k v -> ( Dict comparable k v, Dict comparable k v ) +partition isGood (D dict) = + let + ( good, bad ) = + Dict.partition (\_ ( key, value ) -> isGood key value) dict + in + ( D good, D bad ) + + + +-- LISTS + + +{-| Get all of the keys in a dictionary, in the order that they were inserted +with the most recently inserted key at the head of the list. + + keys (fromList [ ( 0, "Alice" ), ( 1, "Bob" ) ]) + --> [ 1, 0 ] + +-} +keys : (k -> k -> Order) -> Dict c k v -> List k +keys keyComparison (D dict) = + Dict.values dict + |> List.sortWith (\( k1, _ ) ( k2, _ ) -> keyComparison k1 k2) + |> List.map Tuple.first + + +{-| Get all of the values in a dictionary, in the order that they were inserted +with the most recently inserted value at the head of the list. + + values (fromList [ ( 0, "Alice" ), ( 1, "Bob" ) ]) + --> [ "Bob", "Alice" ] + +-} +values : (k -> k -> Order) -> Dict c k v -> List v +values keyComparison (D dict) = + Dict.values dict + |> List.sortWith (\( k1, _ ) ( k2, _ ) -> keyComparison k1 k2) + |> List.map Tuple.second + + +{-| Convert a dictionary into an association list of key-value pairs, in the +order that they were inserted with the most recently inserted entry at the +head of the list. +-} +toList : (k -> k -> Order) -> Dict c k v -> List ( k, v ) +toList keyComparison (D dict) = + Dict.values dict + |> List.sortWith (\( k1, _ ) ( k2, _ ) -> keyComparison k1 k2) + + +{-| Convert an association list into a dictionary. The elements are inserted +from left to right. (If you want to insert the elements from right to left, you +can simply call `List.reverse` on the input before passing it to `fromList`.) +-} +fromList : (k -> comparable) -> List ( k, v ) -> Dict comparable k v +fromList toComparable = + List.foldl (\( key, value ) -> Dict.insert (toComparable key) ( key, value )) Dict.empty + >> D diff --git a/src/Data/Set.elm b/src/Data/Set.elm new file mode 100644 index 0000000000..dddb65a29b --- /dev/null +++ b/src/Data/Set.elm @@ -0,0 +1,179 @@ +module Data.Set exposing + ( EverySet + , empty, singleton, insert, remove + , isEmpty, member, size + , union, intersect, diff + , toList, fromList + , map, foldl, foldr, filter, partition + ) + +{-| **Initial implementation from `Gizra/elm-all-set/1.0.1`** + +A set of unique values. The values can be any type, as the implementation is +based on [AssocList](https://package.elm-lang.org/packages/pzp1997/assoc-list/latest) + + +# Sets + +@docs EverySet + + +# Build + +@docs empty, singleton, insert, remove + + +# Query + +@docs isEmpty, member, size + + +# Combine + +@docs union, intersect, diff + + +# Lists + +@docs toList, fromList + + +# Transform + +@docs map, foldl, foldr, filter, partition + +-} + +import Data.Map as Dict exposing (Dict) + + +{-| Represents a set of unique values. So `(Set Int)` is a set of integers and +`(Set String)` is a set of strings. +-} +type EverySet c a + = EverySet (Dict c a ()) + + +{-| Create an empty set. +-} +empty : EverySet c a +empty = + EverySet Dict.empty + + +{-| Create a set with one value. +-} +singleton : (a -> comparable) -> a -> EverySet comparable a +singleton toComparable k = + EverySet <| Dict.singleton toComparable k () + + +{-| Insert a value into a set. +-} +insert : (a -> comparable) -> a -> EverySet comparable a -> EverySet comparable a +insert toComparable k (EverySet d) = + EverySet <| Dict.insert toComparable k () d + + +{-| Remove a value from a set. If the value is not found, no changes are made. +-} +remove : (a -> comparable) -> a -> EverySet comparable a -> EverySet comparable a +remove toComparable k (EverySet d) = + EverySet <| Dict.remove toComparable k d + + +{-| Determine if a set is empty. +-} +isEmpty : EverySet c a -> Bool +isEmpty (EverySet d) = + Dict.isEmpty d + + +{-| Determine if a value is in a set. +-} +member : (a -> comparable) -> a -> EverySet comparable a -> Bool +member toComparable k (EverySet d) = + Dict.member toComparable k d + + +{-| Determine the number of elements in a set. +-} +size : EverySet c a -> Int +size (EverySet d) = + Dict.size d + + +{-| Get the union of two sets. Keep all values. +-} +union : EverySet comparable a -> EverySet comparable a -> EverySet comparable a +union (EverySet d1) (EverySet d2) = + EverySet <| Dict.union d1 d2 + + +{-| Get the intersection of two sets. Keeps values that appear in both sets. +-} +intersect : (a -> a -> Order) -> EverySet comparable a -> EverySet comparable a -> EverySet comparable a +intersect keyComparison (EverySet d1) (EverySet d2) = + EverySet <| Dict.intersection keyComparison d1 d2 + + +{-| Get the difference between the first set and the second. Keeps values +that do not appear in the second set. +-} +diff : EverySet comparable a -> EverySet comparable a -> EverySet comparable a +diff (EverySet d1) (EverySet d2) = + EverySet <| Dict.diff d1 d2 + + +{-| Convert a set into a list, sorted from lowest to highest. +-} +toList : (a -> a -> Order) -> EverySet c a -> List a +toList keyComparison (EverySet d) = + Dict.keys keyComparison d + + +{-| Convert a list into a set, removing any duplicates. +-} +fromList : (a -> comparable) -> List a -> EverySet comparable a +fromList toComparable xs = + List.foldl (insert toComparable) empty xs + + +{-| Fold over the values in a set, in order from lowest to highest. +-} +foldl : (a -> a -> Order) -> (a -> b -> b) -> b -> EverySet c a -> b +foldl keyComparison f b (EverySet d) = + Dict.foldl keyComparison (\k _ result -> f k result) b d + + +{-| Fold over the values in a set, in order from highest to lowest. +-} +foldr : (a -> a -> Order) -> (a -> b -> b) -> b -> EverySet c a -> b +foldr keyComparison f b (EverySet d) = + Dict.foldr keyComparison (\k _ result -> f k result) b d + + +{-| Map a function onto a set, creating a new set with no duplicates. +-} +map : (a -> a -> Order) -> (a2 -> comparable) -> (a -> a2) -> EverySet comparable a -> EverySet comparable a2 +map keyComparison toString f s = + fromList toString (List.map f (toList keyComparison s)) + + +{-| Create a new set consisting only of elements which satisfy a predicate. +-} +filter : (a -> Bool) -> EverySet comparable a -> EverySet comparable a +filter p (EverySet d) = + EverySet <| Dict.filter (\k _ -> p k) d + + +{-| Create two new sets; the first consisting of elements which satisfy a +predicate, the second consisting of elements which do not. +-} +partition : (a -> Bool) -> EverySet comparable a -> ( EverySet comparable a, EverySet comparable a ) +partition p (EverySet d) = + let + ( p1, p2 ) = + Dict.partition (\k _ -> p k) d + in + ( EverySet p1, EverySet p2 ) diff --git a/src/Data/Vector.elm b/src/Data/Vector.elm new file mode 100644 index 0000000000..002173a45b --- /dev/null +++ b/src/Data/Vector.elm @@ -0,0 +1,74 @@ +module Data.Vector exposing + ( forM_ + , imapM_ + , unsafeFreeze + , unsafeInit + , unsafeLast + ) + +import Array exposing (Array) +import Data.IORef as IORef exposing (IORef) +import System.TypeCheck.IO as IO exposing (IO, Variable) +import Utils.Crash exposing (crash) + + +unsafeLast : IORef (Array (Maybe (List Variable))) -> IO (List Variable) +unsafeLast ioRef = + IORef.readIORefMVector ioRef + |> IO.fmap + (\array -> + case Array.get (Array.length array - 1) array of + Just (Just value) -> + value + + Just Nothing -> + crash "Data.Vector.unsafeLast: invalid value" + + Nothing -> + crash "Data.Vector.unsafeLast: empty array" + ) + + +unsafeInit : IORef (Array (Maybe a)) -> IORef (Array (Maybe a)) +unsafeInit = + identity + + +imapM_ : (Int -> List Variable -> IO b) -> IORef (Array (Maybe (List IO.Variable))) -> IO () +imapM_ action ioRef = + IORef.readIORefMVector ioRef + |> IO.bind + (\value -> + Array.foldl + (\( i, maybeX ) ioAcc -> + case maybeX of + Just x -> + IO.bind + (\acc -> + IO.fmap (\newX -> Array.push (Just newX) acc) + (action i x) + ) + ioAcc + + Nothing -> + ioAcc + ) + (IO.pure Array.empty) + (Array.indexedMap Tuple.pair value) + |> IO.fmap (\_ -> ()) + ) + + +mapM_ : (List IO.Variable -> IO b) -> IORef (Array (Maybe (List IO.Variable))) -> IO () +mapM_ action ioRef = + imapM_ (\_ -> action) ioRef + + +forM_ : IORef (Array (Maybe (List IO.Variable))) -> (List IO.Variable -> IO b) -> IO () +forM_ ioRef action = + mapM_ action ioRef + + +unsafeFreeze : IORef (Array (Maybe a)) -> IO (IORef (Array (Maybe a))) +unsafeFreeze = + IO.pure diff --git a/src/Data/Vector/Mutable.elm b/src/Data/Vector/Mutable.elm new file mode 100644 index 0000000000..7446ca7042 --- /dev/null +++ b/src/Data/Vector/Mutable.elm @@ -0,0 +1,65 @@ +module Data.Vector.Mutable exposing + ( grow + , length + , modify + , read + , replicate + , write + ) + +import Array exposing (Array) +import Array.Extra as Array +import Data.IORef as IORef exposing (IORef) +import System.TypeCheck.IO as IO exposing (IO, Variable) +import Utils.Crash exposing (crash) + + +length : IORef (Array (Maybe (List Variable))) -> IO Int +length = + IORef.readIORefMVector + >> IO.fmap Array.length + + +replicate : Int -> List Variable -> IO (IORef (Array (Maybe (List Variable)))) +replicate n e = + IORef.newIORefMVector (Array.repeat n (Just e)) + + +grow : IORef (Array (Maybe (List Variable))) -> Int -> IO (IORef (Array (Maybe (List Variable)))) +grow ioRef length_ = + IORef.readIORefMVector ioRef + |> IO.bind + (\value -> + IORef.writeIORefMVector ioRef + (Array.append value (Array.repeat length_ Nothing)) + ) + |> IO.fmap (\_ -> ioRef) + + +read : IORef (Array (Maybe (List Variable))) -> Int -> IO (List Variable) +read ioRef i = + IORef.readIORefMVector ioRef + |> IO.fmap + (\array -> + case Array.get i array of + Just (Just value) -> + value + + Just Nothing -> + crash "Data.Vector.read: invalid value" + + Nothing -> + crash "Data.Vector.read: could not find entry" + ) + + +write : IORef (Array (Maybe (List Variable))) -> Int -> List Variable -> IO () +write ioRef i x = + IORef.modifyIORefMVector ioRef + (Array.set i (Just x)) + + +modify : IORef (Array (Maybe (List Variable))) -> (List Variable -> List Variable) -> Int -> IO () +modify ioRef func index = + IORef.modifyIORefMVector ioRef + (Array.update index (Maybe.map func)) diff --git a/src/Node/Format.elm b/src/Node/Format.elm new file mode 100644 index 0000000000..b9061aea3b --- /dev/null +++ b/src/Node/Format.elm @@ -0,0 +1,20 @@ +module Node.Format exposing (run) + +import Common.Format +import Compiler.Elm.Package as Pkg +import Compiler.Parse.Module as M +import Compiler.Parse.SyntaxVersion as SV + + + +-- RUN + + +run : String -> Result String String +run inputText = + Common.Format.format SV.Guida (M.Package Pkg.core) inputText + |> Result.mapError + (\_ -> + -- FIXME missings errs + "Something went wrong..." + ) diff --git a/src/Node/Main.elm b/src/Node/Main.elm new file mode 100644 index 0000000000..b0e3a3cc20 --- /dev/null +++ b/src/Node/Main.elm @@ -0,0 +1,63 @@ +module Node.Main exposing (main) + +import Json.Decode as Decode +import Json.Encode as Encode +import Node.Format as Format +import System.IO as IO +import Task exposing (Task) +import Utils.Impure as Impure +import Utils.Task.Extra as Task + + +main : IO.Program +main = + IO.run app + + +app : Task Never () +app = + getArgs + |> Task.bind + (\args -> + case args of + FormatArgs path -> + case Format.run path of + Ok output -> + exitWithResponse (Encode.object [ ( "output", Encode.string output ) ]) + + Err error -> + exitWithResponse (Encode.object [ ( "error", Encode.string error ) ]) + ) + + +getArgs : Task Never Args +getArgs = + Impure.task "getArgs" [] Impure.EmptyBody (Impure.DecoderResolver argsDecoder) + + +exitWithResponse : Encode.Value -> Task Never a +exitWithResponse value = + Impure.task "exitWithResponse" [] (Impure.JsonBody value) Impure.Crash + + + +-- ARGS + + +type Args + = FormatArgs String + + +argsDecoder : Decode.Decoder Args +argsDecoder = + Decode.field "command" Decode.string + |> Decode.andThen + (\command -> + case command of + "format" -> + Decode.map FormatArgs + (Decode.field "content" Decode.string) + + _ -> + Decode.fail ("Unknown command: " ++ command) + ) diff --git a/src/Prelude.elm b/src/Prelude.elm new file mode 100644 index 0000000000..7f4aef32a3 --- /dev/null +++ b/src/Prelude.elm @@ -0,0 +1,38 @@ +module Prelude exposing + ( head + , init + , last + ) + +import List.Extra as List +import Utils.Crash exposing (crash) + + +head : List a -> a +head items = + case List.head items of + Just item -> + item + + Nothing -> + crash "*** Exception: Prelude.head: empty list" + + +init : List a -> List a +init items = + case List.init items of + Just initItems -> + initItems + + Nothing -> + crash "*** Exception: Prelude.init: empty list" + + +last : List a -> a +last items = + case List.last items of + Just item -> + item + + Nothing -> + crash "*** Exception: Prelude.last: empty list" diff --git a/src/System/Console/Ansi.elm b/src/System/Console/Ansi.elm new file mode 100644 index 0000000000..760688771e --- /dev/null +++ b/src/System/Console/Ansi.elm @@ -0,0 +1,85 @@ +module System.Console.Ansi exposing + ( BlinkSpeed(..) + , Color(..) + , ColorIntensity(..) + , ConsoleIntensity(..) + , ConsoleLayer(..) + , SGR(..) + , Underlining(..) + ) + +-- | ANSI colors: come in various intensities, which are controlled by 'ColorIntensity' + + +type Color + = Black + | Red + | Green + | Yellow + | Blue + | Magenta + | Cyan + | White + + + +-- | ANSI colors come in two intensities + + +type ColorIntensity + = Dull + | Vivid + + + +-- | ANSI colors can be set on two different layers + + +type ConsoleLayer + = Foreground + | Background + + + +-- | ANSI blink speeds: values other than 'NoBlink' are not widely supported + + +type BlinkSpeed + = SlowBlink -- ^ Less than 150 blinks per minute + | RapidBlink -- ^ More than 150 blinks per minute + | NoBlink + + + +-- | ANSI text underlining + + +type Underlining + = SingleUnderline + | DoubleUnderline -- ^ Not widely supported + | NoUnderline + + + +-- | ANSI general console intensity: usually treated as setting the font style (e.g. 'BoldIntensity' causes text to be bold) + + +type ConsoleIntensity + = BoldIntensity + | FaintIntensity -- ^ Not widely supported: sometimes treated as concealing text + | NormalIntensity + + + +-- | ANSI Select Graphic Rendition command + + +type SGR + = Reset + | SetConsoleIntensity ConsoleIntensity + | SetItalicized Bool -- ^ Not widely supported: sometimes treated as swapping foreground and background + | SetUnderlining Underlining + | SetBlinkSpeed BlinkSpeed + | SetVisible Bool -- ^ Not widely supported + | SetSwapForegroundBackground Bool + | SetColor ConsoleLayer ColorIntensity Color diff --git a/src/System/Exit.elm b/src/System/Exit.elm new file mode 100644 index 0000000000..6bce25a096 --- /dev/null +++ b/src/System/Exit.elm @@ -0,0 +1,42 @@ +module System.Exit exposing + ( ExitCode(..) + , exitFailure + , exitSuccess + , exitWith + ) + +import Task exposing (Task) +import Utils.Impure as Impure + + +type ExitCode + = ExitSuccess + | ExitFailure Int + + +exitWith : ExitCode -> Task Never a +exitWith exitCode = + let + code : Int + code = + case exitCode of + ExitSuccess -> + 0 + + ExitFailure int -> + int + in + Impure.task "exitWith" + [] + (Impure.StringBody (String.fromInt code)) + Impure.Crash + + +exitFailure : Task Never a +exitFailure = + exitWith (ExitFailure 1) + + +exitSuccess : Task Never a +exitSuccess = + exitWith ExitSuccess diff --git a/src/System/IO.elm b/src/System/IO.elm new file mode 100644 index 0000000000..3ab6a722b1 --- /dev/null +++ b/src/System/IO.elm @@ -0,0 +1,276 @@ +module System.IO exposing + ( Program, Model, Msg, run + , FilePath, Handle(..) + , stdout, stderr + , withFile, IOMode(..) + , hClose + , hFileSize + , hFlush + , hIsTerminalDevice + , hPutStr, hPutStrLn + , putStr, putStrLn, getLine + , ReplState(..), initialReplState + , writeString + ) + +{-| Ref.: + +@docs Program, Model, Msg, run + + +# Files and handles + +@docs FilePath, Handle + + +# Standard handles + +@docs stdout, stderr + + +# Opening files + +@docs withFile, IOMode + + +# Closing files + +@docs hClose + + +# File locking + +@docs hFileSize + + +# Buffering operations + +@docs hFlush + + +# Terminal operations (not portable: GHC only) + +@docs hIsTerminalDevice + + +# Text output + +@docs hPutStr, hPutStrLn + + +# Special cases for standard input and output + +@docs putStr, putStrLn, getLine + + +# Repl State + +@docs ReplState, initialReplState + + +# Internal helpers + +@docs writeString + +-} + +import Dict exposing (Dict) +import Http +import Json.Decode as Decode +import Task exposing (Task) +import Utils.Impure as Impure + + +type alias Program = + Platform.Program () Model Msg + + +run : Task Never () -> Program +run app = + Platform.worker + { init = update app + , update = update + , subscriptions = \_ -> Sub.none + } + + +type alias Model = + () + + +type alias Msg = + Task Never () + + +update : Msg -> Model -> ( Model, Cmd Msg ) +update msg () = + ( (), Task.perform Task.succeed msg ) + + + +-- Interal helpers + + +writeString : FilePath -> String -> Task Never () +writeString path content = + Impure.task "writeString" + [ Http.header "path" path ] + (Impure.StringBody content) + (Impure.Always ()) + + + +-- Task extra + + +pure : a -> Task x a +pure = + Task.succeed + + + +-- Files and handles + + +type alias FilePath = + String + + +type Handle + = Handle Int + + + +-- Standard handles + + +stdout : Handle +stdout = + Handle 1 + + +stderr : Handle +stderr = + Handle 2 + + + +-- Opening files + + +withFile : String -> IOMode -> (Handle -> Task Never a) -> Task Never a +withFile path mode callback = + Impure.task "withFile" + [ Http.header "mode" + (case mode of + ReadMode -> + "r" + + WriteMode -> + "w" + + AppendMode -> + "a" + + ReadWriteMode -> + "w+" + ) + ] + (Impure.StringBody path) + (Impure.DecoderResolver (Decode.map Handle Decode.int)) + |> Task.andThen callback + + +type IOMode + = ReadMode + | WriteMode + | AppendMode + | ReadWriteMode + + + +-- Closing files + + +hClose : Handle -> Task Never () +hClose (Handle handle) = + Impure.task "hClose" [] (Impure.StringBody (String.fromInt handle)) (Impure.Always ()) + + + +-- File locking + + +hFileSize : Handle -> Task Never Int +hFileSize (Handle handle) = + Impure.task "hFileSize" + [] + (Impure.StringBody (String.fromInt handle)) + (Impure.DecoderResolver Decode.int) + + + +-- Buffering operations + + +hFlush : Handle -> Task Never () +hFlush _ = + pure () + + + +-- Terminal operations (not portable: GHC only) + + +hIsTerminalDevice : Handle -> Task Never Bool +hIsTerminalDevice _ = + pure True + + + +-- Text output + + +hPutStr : Handle -> String -> Task Never () +hPutStr (Handle fd) content = + Impure.task "hPutStr" + [ Http.header "fd" (String.fromInt fd) ] + (Impure.StringBody content) + (Impure.Always ()) + + +hPutStrLn : Handle -> String -> Task Never () +hPutStrLn handle content = + hPutStr handle (content ++ "\n") + + + +-- Special cases for standard input and output + + +putStr : String -> Task Never () +putStr = + hPutStr stdout + + +putStrLn : String -> Task Never () +putStrLn s = + putStr (s ++ "\n") + + +getLine : Task Never String +getLine = + Impure.task "getLine" [] Impure.EmptyBody (Impure.StringResolver identity) + + + +-- Repl State (Terminal.Repl) + + +type ReplState + = ReplState (Dict String String) (Dict String String) (Dict String String) + + +initialReplState : ReplState +initialReplState = + ReplState Dict.empty Dict.empty Dict.empty diff --git a/src/System/Process.elm b/src/System/Process.elm new file mode 100644 index 0000000000..9a76b8ace6 --- /dev/null +++ b/src/System/Process.elm @@ -0,0 +1,140 @@ +module System.Process exposing + ( CmdSpec + , CreateProcess + , ProcessHandle + , StdStream(..) + , proc + , waitForProcess + , withCreateProcess + ) + +import Json.Decode as Decode +import Json.Encode as Encode +import System.Exit as Exit +import System.IO as IO +import Task exposing (Task) +import Utils.Impure as Impure +import Utils.Task.Extra as Task + + +type CmdSpec + = RawCommand String (List String) + + +type alias CreateProcess = + { cmdspec : CmdSpec + , std_in : StdStream + , std_out : StdStream + , std_err : StdStream + } + + +type StdStream + = Inherit + | UseHandle IO.Handle + | CreatePipe + | NoStream + + +type ProcessHandle + = ProcessHandle Int + + +proc : String -> List String -> CreateProcess +proc cmd args = + { cmdspec = RawCommand cmd args + , std_in = Inherit + , std_out = Inherit + , std_err = Inherit + } + + +withCreateProcess : CreateProcess -> (Maybe IO.Handle -> Maybe IO.Handle -> Maybe IO.Handle -> ProcessHandle -> Task Never Exit.ExitCode) -> Task Never Exit.ExitCode +withCreateProcess createProcess f = + Impure.task "withCreateProcess" + [] + (Impure.JsonBody + (Encode.object + [ ( "cmdspec" + , case createProcess.cmdspec of + RawCommand cmd args -> + Encode.object + [ ( "type", Encode.string "RawCommand" ) + , ( "cmd", Encode.string cmd ) + , ( "args", Encode.list Encode.string args ) + ] + ) + , ( "stdin" + , case createProcess.std_in of + Inherit -> + Encode.string "inherit" + + UseHandle (IO.Handle handle) -> + Encode.int handle + + CreatePipe -> + Encode.string "pipe" + + NoStream -> + Encode.string "ignore" + ) + , ( "stdout" + , case createProcess.std_out of + Inherit -> + Encode.string "inherit" + + UseHandle (IO.Handle handle) -> + Encode.int handle + + CreatePipe -> + Encode.string "pipe" + + NoStream -> + Encode.string "ignore" + ) + , ( "stderr" + , case createProcess.std_err of + Inherit -> + Encode.string "inherit" + + UseHandle (IO.Handle handle) -> + Encode.int handle + + CreatePipe -> + Encode.string "pipe" + + NoStream -> + Encode.string "ignore" + ) + ] + ) + ) + (Impure.DecoderResolver + (Decode.map2 Tuple.pair + (Decode.field "stdinHandle" (Decode.maybe Decode.int)) + (Decode.field "ph" Decode.int) + ) + ) + |> Task.bind + (\( stdinHandle, ph ) -> + f (Maybe.map IO.Handle stdinHandle) Nothing Nothing (ProcessHandle ph) + ) + + +waitForProcess : ProcessHandle -> Task Never Exit.ExitCode +waitForProcess (ProcessHandle ph) = + Impure.task "waitForProcess" + [] + (Impure.StringBody (String.fromInt ph)) + (Impure.DecoderResolver + (Decode.map + (\int -> + if int == 0 then + Exit.ExitSuccess + + else + Exit.ExitFailure int + ) + Decode.int + ) + ) diff --git a/src/System/TypeCheck/IO.elm b/src/System/TypeCheck/IO.elm new file mode 100644 index 0000000000..a3bbb63fd6 --- /dev/null +++ b/src/System/TypeCheck/IO.elm @@ -0,0 +1,325 @@ +module System.TypeCheck.IO exposing + ( unsafePerformIO + , IO, State, pure, apply, fmap, bind, foldrM, foldM, traverseMap, traverseMapWithKey, forM_, mapM_ + , foldMDict, indexedForA, mapM, traverseIndexed, traverseList, traverseMaybe, traverseTuple + , Step(..), loop + , Point(..), PointInfo(..) + , Descriptor(..), Content(..), SuperType(..), Mark(..), Variable, FlatType(..) + , Canonical(..) + ) + +{-| Ref.: + +@docs unsafePerformIO + + +# The IO monad + +@docs IO, State, pure, apply, fmap, bind, foldrM, foldM, traverseMap, traverseMapWithKey, forM_, mapM_ +@docs foldMDict, indexedForA, mapM, traverseIndexed, traverseList, traverseMaybe, traverseTuple + + +# Loop + +@docs Step, loop + + +# Point + +@docs Point, PointInfo + + +# Compiler.Type.Type + +@docs Descriptor, Content, SuperType, Mark, Variable, FlatType + + +# Compiler.Elm.ModuleName + +@docs Canonical + +-} + +import Array exposing (Array) +import Compiler.Data.Index as Index +import Data.Map as Dict exposing (Dict) + + +unsafePerformIO : IO a -> a +unsafePerformIO ioA = + { ioRefsWeight = Array.empty + , ioRefsPointInfo = Array.empty + , ioRefsDescriptor = Array.empty + , ioRefsMVector = Array.empty + } + |> ioA + |> Tuple.second + + + +-- LOOP + + +type Step state a + = Loop state + | Done a + + +loop : (state -> IO (Step state a)) -> state -> IO a +loop callback loopState ioState = + case callback loopState ioState of + ( newIOState, Loop newLoopState ) -> + loop callback newLoopState newIOState + + ( newIOState, Done a ) -> + ( newIOState, a ) + + + +-- The IO monad + + +type alias IO a = + State -> ( State, a ) + + +type alias State = + { ioRefsWeight : Array Int + , ioRefsPointInfo : Array PointInfo + , ioRefsDescriptor : Array Descriptor + , ioRefsMVector : Array (Array (Maybe (List Variable))) + } + + +pure : a -> IO a +pure x = + \s -> ( s, x ) + + +apply : IO a -> IO (a -> b) -> IO b +apply ma mf = + bind (\f -> bind (pure << f) ma) mf + + +fmap : (a -> b) -> IO a -> IO b +fmap fn ma s0 = + let + ( s1, a ) = + ma s0 + in + ( s1, fn a ) + + +bind : (a -> IO b) -> IO a -> IO b +bind f ma = + \s0 -> + let + ( s1, a ) = + ma s0 + in + f a s1 + + +foldrM : (a -> b -> IO b) -> b -> List a -> IO b +foldrM f z0 xs = + loop (foldrMHelp f) ( xs, z0 ) + + +foldrMHelp : (a -> b -> IO b) -> ( List a, b ) -> IO (Step ( List a, b ) b) +foldrMHelp callback ( list, result ) = + case list of + [] -> + pure (Done result) + + a :: rest -> + fmap (\b -> Loop ( rest, b )) (callback a result) + + +foldM : (b -> a -> IO b) -> b -> List a -> IO b +foldM f b list = + loop (foldMHelp f) ( list, b ) + + +foldMHelp : (b -> a -> IO b) -> ( List a, b ) -> IO (Step ( List a, b ) b) +foldMHelp callback ( list, result ) = + case list of + [] -> + pure (Done result) + + a :: rest -> + fmap (\b -> Loop ( rest, b )) (callback result a) + + +traverseMap : (k -> comparable) -> (k -> k -> Order) -> (a -> IO b) -> Dict comparable k a -> IO (Dict comparable k b) +traverseMap toComparable keyComparison f = + traverseMapWithKey toComparable keyComparison (\_ -> f) + + +traverseMapWithKey : (k -> comparable) -> (k -> k -> Order) -> (k -> a -> IO b) -> Dict comparable k a -> IO (Dict comparable k b) +traverseMapWithKey toComparable keyComparison f dict = + loop (traverseWithKeyHelp toComparable f) ( Dict.toList keyComparison dict, Dict.empty ) + + +traverseWithKeyHelp : (k -> comparable) -> (k -> a -> IO b) -> ( List ( k, a ), Dict comparable k b ) -> IO (Step ( List ( k, a ), Dict comparable k b ) (Dict comparable k b)) +traverseWithKeyHelp toComparable callback ( pairs, result ) = + case pairs of + [] -> + pure (Done result) + + ( k, a ) :: rest -> + fmap (\b -> Loop ( rest, Dict.insert toComparable k b result )) (callback k a) + + +mapM_ : (a -> IO b) -> List a -> IO () +mapM_ f list = + loop (mapMHelp_ f) ( List.reverse list, pure () ) + + +mapMHelp_ : (a -> IO b) -> ( List a, IO () ) -> IO (Step ( List a, IO () ) ()) +mapMHelp_ callback ( list, result ) = + case list of + [] -> + fmap Done result + + a :: rest -> + fmap (\_ -> Loop ( rest, result )) (callback a) + + +forM_ : List a -> (a -> IO b) -> IO () +forM_ list f = + mapM_ f list + + +foldMDict : (k -> k -> Order) -> (b -> a -> IO b) -> b -> Dict c k a -> IO b +foldMDict keyComparison f b = + Dict.foldl keyComparison (\_ a -> bind (\acc -> f acc a)) (pure b) + + +traverseList : (a -> IO b) -> List a -> IO (List b) +traverseList f = + List.foldr (\a -> bind (\c -> fmap (\va -> va :: c) (f a))) + (pure []) + + +traverseTuple : (b -> IO c) -> ( a, b ) -> IO ( a, c ) +traverseTuple f ( a, b ) = + fmap (Tuple.pair a) (f b) + + +traverseMaybe : (a -> IO b) -> Maybe a -> IO (Maybe b) +traverseMaybe f a = + case Maybe.map f a of + Just b -> + fmap Just b + + Nothing -> + pure Nothing + + +mapM : (a -> IO b) -> List a -> IO (List b) +mapM = + traverseList + + +traverseIndexed : (Index.ZeroBased -> a -> IO b) -> List a -> IO (List b) +traverseIndexed func xs = + sequenceAList (Index.indexedMap func xs) + + +indexedForA : List a -> (Index.ZeroBased -> a -> IO b) -> IO (List b) +indexedForA xs func = + sequenceAList (Index.indexedMap func xs) + + +sequenceAList : List (IO a) -> IO (List a) +sequenceAList = + List.foldr (\x acc -> apply acc (fmap (::) x)) (pure []) + + + +-- POINT + + +{-| FIXME Compiler.Type.UnionFind +-} +type Point + = Pt Int + + +{-| FIXME Compiler.Type.UnionFind +-} +type PointInfo + = Info Int Int + | Link Point + + + +-- DESCRIPTORS + + +{-| FIXME Compiler.Type.Type +-} +type Descriptor + = Descriptor Content Int Mark (Maybe Variable) + + +{-| FIXME Compiler.Type.Type +-} +type Content + = FlexVar (Maybe String) + | FlexSuper SuperType (Maybe String) + | RigidVar String + | RigidSuper SuperType String + | Structure FlatType + | Alias Canonical String (List ( String, Variable )) Variable + | Error + + +{-| FIXME Compiler.Type.Type +-} +type SuperType + = Number + | Comparable + | Appendable + | CompAppend + + + +-- MARKS + + +{-| FIXME Compiler.Type.Type +-} +type Mark + = Mark Int + + + +-- TYPE PRIMITIVES + + +{-| FIXME Compiler.Type.Type +-} +type alias Variable = + Point + + +{-| FIXME Compiler.Type.Type +-} +type FlatType + = App1 Canonical String (List Variable) + | Fun1 Variable Variable + | EmptyRecord1 + | Record1 (Dict String String Variable) Variable + | Unit1 + | Tuple1 Variable Variable (List Variable) + + + +-- CANONICAL + + +{-| FIXME Compiler.Elm.ModuleName +-} +type Canonical + = Canonical ( String, String ) String diff --git a/src/Terminal/Bump.elm b/src/Terminal/Bump.elm new file mode 100644 index 0000000000..be1157eba3 --- /dev/null +++ b/src/Terminal/Bump.elm @@ -0,0 +1,221 @@ +module Terminal.Bump exposing (run) + +import Builder.BackgroundWriter as BW +import Builder.Build as Build +import Builder.Deps.Bump as Bump +import Builder.Deps.Diff as Diff +import Builder.Deps.Registry as Registry +import Builder.Elm.Details as Details +import Builder.Elm.Outline as Outline +import Builder.Http as Http +import Builder.Reporting as Reporting +import Builder.Reporting.Exit as Exit +import Builder.Reporting.Exit.Help as Help +import Builder.Stuff as Stuff +import Compiler.Data.NonEmptyList as NE +import Compiler.Elm.Docs as Docs +import Compiler.Elm.Magnitude as M +import Compiler.Elm.Version as V +import Compiler.Reporting.Doc as D +import Prelude +import System.IO as IO +import Task exposing (Task) +import Utils.Main as Utils exposing (FilePath) +import Utils.Task.Extra as Task + + + +-- RUN + + +run : () -> () -> Task Never () +run () () = + Reporting.attempt Exit.bumpToReport <| + Task.run (Task.bind bump getEnv) + + + +-- ENV + + +type Env + = Env FilePath Stuff.PackageCache Http.Manager Registry.Registry Outline.PkgOutline + + +getEnv : Task Exit.Bump Env +getEnv = + Task.io Stuff.findRoot + |> Task.bind + (\maybeRoot -> + case maybeRoot of + Nothing -> + Task.throw Exit.BumpNoOutline + + Just root -> + Task.io Stuff.getPackageCache + |> Task.bind + (\cache -> + Task.io Http.getManager + |> Task.bind + (\manager -> + Task.eio Exit.BumpMustHaveLatestRegistry (Registry.latest manager cache) + |> Task.bind + (\registry -> + Task.eio Exit.BumpBadOutline (Outline.read root) + |> Task.bind + (\outline -> + case outline of + Outline.App _ -> + Task.throw Exit.BumpApplication + + Outline.Pkg pkgOutline -> + Task.pure (Env root cache manager registry pkgOutline) + ) + ) + ) + ) + ) + + + +-- BUMP + + +bump : Env -> Task Exit.Bump () +bump ((Env root _ _ registry ((Outline.PkgOutline pkg _ _ vsn _ _ _ _) as outline)) as env) = + case Registry.getVersions pkg registry of + Just knownVersions -> + let + bumpableVersions : List V.Version + bumpableVersions = + List.map (\( old, _, _ ) -> old) (Bump.getPossibilities knownVersions) + in + if List.member vsn bumpableVersions then + suggestVersion env + + else + Task.throw <| + Exit.BumpUnexpectedVersion vsn <| + List.map Prelude.head (Utils.listGroupBy (==) (List.sortWith V.compare bumpableVersions)) + + Nothing -> + Task.io <| checkNewPackage root outline + + + +-- CHECK NEW PACKAGE + + +checkNewPackage : FilePath -> Outline.PkgOutline -> Task Never () +checkNewPackage root ((Outline.PkgOutline _ _ _ version _ _ _ _) as outline) = + IO.putStrLn Exit.newPackageOverview + |> Task.bind + (\_ -> + if version == V.one then + IO.putStrLn "The version number in elm.json is correct so you are all set!" + + else + changeVersion root outline V.one <| + (D.fromChars "It looks like the version in elm.json has been changed though!\nWould you like me to change it back to " + |> D.a (D.fromVersion V.one) + |> D.a (D.fromChars "? [Y/n] ") + ) + ) + + + +-- SUGGEST VERSION + + +suggestVersion : Env -> Task Exit.Bump () +suggestVersion (Env root cache manager _ ((Outline.PkgOutline pkg _ _ vsn _ _ _ _) as outline)) = + Task.eio (Exit.BumpCannotFindDocs vsn) (Diff.getDocs cache manager pkg vsn) + |> Task.bind + (\oldDocs -> + generateDocs root outline + |> Task.bind + (\newDocs -> + let + changes : Diff.PackageChanges + changes = + Diff.diff oldDocs newDocs + + newVersion : V.Version + newVersion = + Diff.bump changes vsn + + old : D.Doc + old = + D.fromVersion vsn + + new : D.Doc + new = + D.fromVersion newVersion + + mag : D.Doc + mag = + D.fromChars <| M.toChars (Diff.toMagnitude changes) + in + Task.io <| + changeVersion root outline newVersion <| + (D.fromChars "Based on your new API, this should be a" + |> D.plus (D.green mag) + |> D.plus (D.fromChars "change (") + |> D.a old + |> D.a (D.fromChars " => ") + |> D.a new + |> D.a (D.fromChars ")\n") + |> D.a (D.fromChars "Bail out of this command and run 'elm diff' for a full explanation.\n") + |> D.a (D.fromChars "\n") + |> D.a (D.fromChars "Should I perform the update (") + |> D.a old + |> D.a (D.fromChars " => ") + |> D.a new + |> D.a (D.fromChars ") in elm.json? [Y/n] ") + ) + ) + ) + + +generateDocs : FilePath -> Outline.PkgOutline -> Task Exit.Bump Docs.Documentation +generateDocs root (Outline.PkgOutline _ _ _ _ exposed _ _ _) = + Task.eio Exit.BumpBadDetails + (BW.withScope (\scope -> Details.load Reporting.silent scope root)) + |> Task.bind + (\details -> + case Outline.flattenExposed exposed of + [] -> + Task.throw <| Exit.BumpNoExposed + + e :: es -> + Task.eio Exit.BumpBadBuild <| + Build.fromExposed Docs.bytesDecoder Docs.bytesEncoder Reporting.silent root details Build.keepDocs (NE.Nonempty e es) + ) + + + +-- CHANGE VERSION + + +changeVersion : FilePath -> Outline.PkgOutline -> V.Version -> D.Doc -> Task Never () +changeVersion root (Outline.PkgOutline name summary license _ exposed deps testDeps elmVersion) targetVersion question = + Reporting.ask question + |> Task.bind + (\approved -> + if not approved then + IO.putStrLn "Okay, I did not change anything!" + + else + Outline.write root + (Outline.Pkg + (Outline.PkgOutline name summary license targetVersion exposed deps testDeps elmVersion) + ) + |> Task.bind + (\_ -> + Help.toStdout + (D.fromChars "Version changed to " + |> D.a (D.green (D.fromVersion targetVersion)) + |> D.a (D.fromChars "!\n") + ) + ) + ) diff --git a/src/Terminal/Diff.elm b/src/Terminal/Diff.elm new file mode 100644 index 0000000000..144599ddff --- /dev/null +++ b/src/Terminal/Diff.elm @@ -0,0 +1,461 @@ +module Terminal.Diff exposing + ( Args(..) + , run + ) + +import Basics.Extra exposing (flip) +import Builder.BackgroundWriter as BW +import Builder.Build as Build +import Builder.Deps.Diff as DD exposing (Changes(..), ModuleChanges(..), PackageChanges(..)) +import Builder.Deps.Registry as Registry +import Builder.Elm.Details as Details exposing (Details(..)) +import Builder.Elm.Outline as Outline +import Builder.Http as Http +import Builder.Reporting as Reporting +import Builder.Reporting.Exit as Exit +import Builder.Reporting.Exit.Help as Help +import Builder.Stuff as Stuff +import Compiler.AST.Utils.Binop as Binop +import Compiler.Data.Name as Name +import Compiler.Data.NonEmptyList as NE +import Compiler.Elm.Compiler.Type as Type +import Compiler.Elm.Docs as Docs +import Compiler.Elm.Magnitude as M +import Compiler.Elm.Package as Pkg +import Compiler.Elm.Version as V +import Compiler.Reporting.Doc as D +import Compiler.Reporting.Render.Type as Type +import Compiler.Reporting.Render.Type.Localizer as L +import Data.Map as Dict +import Task exposing (Task) +import Utils.Task.Extra as Task + + + +-- RUN + + +type Args + = CodeVsLatest + | CodeVsExactly V.Version + | LocalInquiry V.Version V.Version + | GlobalInquiry Pkg.Name V.Version V.Version + + +run : Args -> () -> Task Never () +run args () = + Reporting.attempt Exit.diffToReport + (Task.run + (getEnv + |> Task.bind (\env -> diff env args) + ) + ) + + + +-- ENVIRONMENT + + +type Env + = Env (Maybe String) Stuff.PackageCache Http.Manager Registry.Registry + + +getEnv : Task Exit.Diff Env +getEnv = + Task.io Stuff.findRoot + |> Task.bind + (\maybeRoot -> + Task.io Stuff.getPackageCache + |> Task.bind + (\cache -> + Task.io Http.getManager + |> Task.bind + (\manager -> + Task.eio Exit.DiffMustHaveLatestRegistry (Registry.latest manager cache) + |> Task.fmap (\registry -> Env maybeRoot cache manager registry) + ) + ) + ) + + + +-- DIFF + + +diff : Env -> Args -> Task Exit.Diff () +diff ((Env _ _ _ registry) as env) args = + case args of + GlobalInquiry name v1 v2 -> + case Registry.getVersions_ name registry of + Ok vsns -> + getDocs env name vsns (V.min v1 v2) + |> Task.bind + (\oldDocs -> + getDocs env name vsns (V.max v1 v2) + |> Task.bind (\newDocs -> writeDiff oldDocs newDocs) + ) + + Err suggestions -> + Task.throw <| Exit.DiffUnknownPackage name suggestions + + LocalInquiry v1 v2 -> + readOutline env + |> Task.bind + (\( name, vsns ) -> + getDocs env name vsns (V.min v1 v2) + |> Task.bind + (\oldDocs -> + getDocs env name vsns (V.max v1 v2) + |> Task.bind (\newDocs -> writeDiff oldDocs newDocs) + ) + ) + + CodeVsLatest -> + readOutline env + |> Task.bind + (\( name, vsns ) -> + getLatestDocs env name vsns + |> Task.bind + (\oldDocs -> + generateDocs env + |> Task.bind (\newDocs -> writeDiff oldDocs newDocs) + ) + ) + + CodeVsExactly version -> + readOutline env + |> Task.bind + (\( name, vsns ) -> + getDocs env name vsns version + |> Task.bind + (\oldDocs -> + generateDocs env + |> Task.bind (\newDocs -> writeDiff oldDocs newDocs) + ) + ) + + + +-- GET DOCS + + +getDocs : Env -> Pkg.Name -> Registry.KnownVersions -> V.Version -> Task Exit.Diff Docs.Documentation +getDocs (Env _ cache manager _) name (Registry.KnownVersions latest previous) version = + if latest == version || List.member version previous then + Task.eio (Exit.DiffDocsProblem version) <| DD.getDocs cache manager name version + + else + Task.throw <| Exit.DiffUnknownVersion version (latest :: previous) + + +getLatestDocs : Env -> Pkg.Name -> Registry.KnownVersions -> Task Exit.Diff Docs.Documentation +getLatestDocs (Env _ cache manager _) name (Registry.KnownVersions latest _) = + Task.eio (Exit.DiffDocsProblem latest) <| DD.getDocs cache manager name latest + + + +-- READ OUTLINE + + +readOutline : Env -> Task Exit.Diff ( Pkg.Name, Registry.KnownVersions ) +readOutline (Env maybeRoot _ _ registry) = + case maybeRoot of + Nothing -> + Task.throw <| Exit.DiffNoOutline + + Just root -> + Task.io (Outline.read root) + |> Task.bind + (\result -> + case result of + Err err -> + Task.throw <| Exit.DiffBadOutline err + + Ok outline -> + case outline of + Outline.App _ -> + Task.throw <| Exit.DiffApplication + + Outline.Pkg (Outline.PkgOutline pkg _ _ _ _ _ _ _) -> + case Registry.getVersions pkg registry of + Just vsns -> + Task.pure ( pkg, vsns ) + + Nothing -> + Task.throw Exit.DiffUnpublished + ) + + + +-- GENERATE DOCS + + +generateDocs : Env -> Task Exit.Diff Docs.Documentation +generateDocs (Env maybeRoot _ _ _) = + case maybeRoot of + Nothing -> + Task.throw <| Exit.DiffNoOutline + + Just root -> + Task.eio Exit.DiffBadDetails + (BW.withScope (\scope -> Details.load Reporting.silent scope root)) + |> Task.bind + (\((Details _ outline _ _ _ _) as details) -> + case outline of + Details.ValidApp _ -> + Task.throw Exit.DiffApplication + + Details.ValidPkg _ exposed _ -> + case exposed of + [] -> + Task.throw Exit.DiffNoExposed + + e :: es -> + Task.eio Exit.DiffBadBuild <| + Build.fromExposed Docs.bytesDecoder Docs.bytesEncoder Reporting.silent root details Build.keepDocs (NE.Nonempty e es) + ) + + + +-- WRITE DIFF + + +writeDiff : Docs.Documentation -> Docs.Documentation -> Task Exit.Diff () +writeDiff oldDocs newDocs = + let + changes : PackageChanges + changes = + DD.diff oldDocs newDocs + + localizer : L.Localizer + localizer = + L.fromNames (Dict.union oldDocs newDocs) + in + Task.io (Help.toStdout (toDoc localizer changes |> D.a (D.fromChars "\n"))) + + + +-- TO DOC + + +toDoc : L.Localizer -> PackageChanges -> D.Doc +toDoc localizer ((PackageChanges added changed removed) as changes) = + if List.isEmpty added && Dict.isEmpty changed && List.isEmpty removed then + D.fromChars "No API changes detected, so this is a" + |> D.plus (D.green (D.fromChars "PATCH")) + |> D.plus (D.fromChars "change.") + + else + let + magDoc : D.Doc + magDoc = + D.fromChars (M.toChars (DD.toMagnitude changes)) + + header : D.Doc + header = + D.fromChars "This is a" + |> D.plus (D.green magDoc) + |> D.plus (D.fromChars "change.") + + addedChunk : List Chunk + addedChunk = + if List.isEmpty added then + [] + + else + [ Chunk "ADDED MODULES" M.MINOR <| + D.vcat <| + List.map D.fromName added + ] + + removedChunk : List Chunk + removedChunk = + if List.isEmpty removed then + [] + + else + [ Chunk "REMOVED MODULES" M.MAJOR <| + D.vcat <| + List.map D.fromName removed + ] + + chunks : List Chunk + chunks = + addedChunk ++ removedChunk ++ List.map (changesToChunk localizer) (Dict.toList compare changed) + in + D.vcat (header :: D.fromChars "" :: List.map chunkToDoc chunks) + + +type Chunk + = Chunk String M.Magnitude D.Doc + + +chunkToDoc : Chunk -> D.Doc +chunkToDoc (Chunk title magnitude details) = + let + header : D.Doc + header = + D.fromChars "----" + |> D.plus (D.fromChars title) + |> D.plus (D.fromChars "-") + |> D.plus (D.fromChars (M.toChars magnitude)) + |> D.plus (D.fromChars "----") + in + D.vcat + [ D.dullcyan header + , D.fromChars "" + , D.indent 4 details + , D.fromChars "" + , D.fromChars "" + ] + + +changesToChunk : L.Localizer -> ( Name.Name, ModuleChanges ) -> Chunk +changesToChunk localizer ( name, (ModuleChanges unions aliases values binops) as changes ) = + let + magnitude : M.Magnitude + magnitude = + DD.moduleChangeMagnitude changes + + ( unionAdd, unionChange, unionRemove ) = + changesToDocTriple compare (unionToDoc localizer) unions + + ( aliasAdd, aliasChange, aliasRemove ) = + changesToDocTriple compare (aliasToDoc localizer) aliases + + ( valueAdd, valueChange, valueRemove ) = + changesToDocTriple compare (valueToDoc localizer) values + + ( binopAdd, binopChange, binopRemove ) = + changesToDocTriple compare (binopToDoc localizer) binops + in + Chunk name magnitude <| + D.vcat <| + List.intersperse (D.fromChars "") <| + List.filterMap identity <| + [ changesToDoc "Added" unionAdd aliasAdd valueAdd binopAdd + , changesToDoc "Removed" unionRemove aliasRemove valueRemove binopRemove + , changesToDoc "Changed" unionChange aliasChange valueChange binopChange + ] + + +changesToDocTriple : (k -> k -> Order) -> (k -> v -> D.Doc) -> Changes comparable k v -> ( List D.Doc, List D.Doc, List D.Doc ) +changesToDocTriple keyComparison entryToDoc (Changes added changed removed) = + let + indented : ( k, v ) -> D.Doc + indented ( name, value ) = + D.indent 4 (entryToDoc name value) + + diffed : ( k, ( v, v ) ) -> D.Doc + diffed ( name, ( oldValue, newValue ) ) = + D.vcat + [ D.fromChars " - " |> D.a (entryToDoc name oldValue) + , D.fromChars " + " |> D.a (entryToDoc name newValue) + , D.fromChars "" + ] + in + ( List.map indented (Dict.toList keyComparison added) + , List.map diffed (Dict.toList keyComparison changed) + , List.map indented (Dict.toList keyComparison removed) + ) + + +changesToDoc : String -> List D.Doc -> List D.Doc -> List D.Doc -> List D.Doc -> Maybe D.Doc +changesToDoc categoryName unions aliases values binops = + if List.isEmpty unions && List.isEmpty aliases && List.isEmpty values && List.isEmpty binops then + Nothing + + else + Just <| + D.vcat <| + D.append (D.fromChars categoryName) (D.fromChars ":") + :: unions + ++ aliases + ++ binops + ++ values + + +unionToDoc : L.Localizer -> Name.Name -> Docs.Union -> D.Doc +unionToDoc localizer name (Docs.Union _ tvars ctors) = + let + setup : D.Doc + setup = + D.fromChars "type" + |> D.plus (D.fromName name) + |> D.plus (D.hsep (List.map D.fromName tvars)) + + ctorDoc : ( Name.Name, List Type.Type ) -> D.Doc + ctorDoc ( ctor, tipes ) = + typeDoc localizer (Type.Type ctor tipes) + in + D.hang 4 + (D.sep + (setup + :: List.map2 (flip D.plus) + (D.fromChars "=" :: List.repeat (List.length ctors - 1) (D.fromChars "|")) + (List.map ctorDoc ctors) + ) + ) + + +aliasToDoc : L.Localizer -> Name.Name -> Docs.Alias -> D.Doc +aliasToDoc localizer name (Docs.Alias _ tvars tipe) = + let + declaration : D.Doc + declaration = + D.plus (D.fromChars "type") + (D.plus (D.fromChars "alias") + (D.plus (D.hsep (List.map D.fromName (name :: tvars))) + (D.fromChars "=") + ) + ) + in + D.hang 4 (D.sep [ declaration, typeDoc localizer tipe ]) + + +valueToDoc : L.Localizer -> Name.Name -> Docs.Value -> D.Doc +valueToDoc localizer name (Docs.Value _ tipe) = + D.hang 4 <| D.sep [ D.fromName name |> D.plus (D.fromChars ":"), typeDoc localizer tipe ] + + +binopToDoc : L.Localizer -> Name.Name -> Docs.Binop -> D.Doc +binopToDoc localizer name (Docs.Binop _ tipe associativity n) = + let + details : D.Doc + details = + D.plus (D.fromChars " (") + (D.plus (D.fromName assoc) + (D.plus (D.fromChars "/") + (D.plus (D.fromInt n) + (D.fromChars ")") + ) + ) + ) + + assoc : String + assoc = + case associativity of + Binop.Left -> + "left" + + Binop.Non -> + "non" + + Binop.Right -> + "right" + in + D.plus (D.fromChars "(") + (D.plus (D.fromName name) + (D.plus (D.fromChars ")") + (D.plus (D.fromChars ":") + (D.plus (typeDoc localizer tipe) + (D.black details) + ) + ) + ) + ) + + +typeDoc : L.Localizer -> Type.Type -> D.Doc +typeDoc localizer tipe = + Type.toDoc localizer Type.None tipe diff --git a/src/Terminal/Format.elm b/src/Terminal/Format.elm new file mode 100644 index 0000000000..a9919e7906 --- /dev/null +++ b/src/Terminal/Format.elm @@ -0,0 +1,745 @@ +module Terminal.Format exposing + ( Flags(..) + , run + ) + +import Builder.File as File +import Common.Format +import Compiler.Elm.Package as Pkg +import Compiler.Parse.Module as M +import Compiler.Parse.SyntaxVersion as SV +import Compiler.Reporting.Annotation as A +import Compiler.Reporting.Error.Syntax as E +import Json.Encode as Encode +import Result.Extra as Result +import System.Exit as Exit +import System.IO as IO +import Task exposing (Task) +import Utils.Main as Utils exposing (FilePath) +import Utils.Task.Extra as Task + + + +-- RUN + + +type Flags + = Flags (Maybe FilePath) Bool Bool Bool + + +run : List String -> Flags -> Task Never () +run paths ((Flags _ autoYes _ _) as flags) = + resolveElmFiles paths + |> Task.bind + (\resolvedInputFiles -> + case determineWhatToDoFromConfig flags resolvedInputFiles of + Err err -> + IO.hPutStrLn IO.stderr (toConsoleErrorMessage err) + |> Task.bind (\_ -> Exit.exitFailure) + + Ok a -> + Task.pure a + ) + |> Task.bind (\whatToDo -> doIt autoYes whatToDo) + |> Task.bind + (\result -> + if result then + Task.pure () + + else + Exit.exitFailure + ) + + +type WhatToDo + = Format TransformMode + | Validate ValidateMode + + +type Source + = Stdin + | FromFiles FilePath (List FilePath) + + +type Destination + = InPlace + | ToFile FilePath + + +type Mode + = FormatMode + | ValidateMode + + +determineSource : Bool -> Result (List Error) (List FilePath) -> Result ErrorMessage Source +determineSource stdin inputFiles = + case ( stdin, inputFiles ) of + ( _, Err fileErrors ) -> + Err (BadInputFiles fileErrors) + + ( True, Ok [] ) -> + Ok Stdin + + ( False, Ok [] ) -> + Err NoInputs + + ( False, Ok (first :: rest) ) -> + Ok (FromFiles first rest) + + ( True, Ok (_ :: _) ) -> + Err TooManyInputs + + +determineDestination : Maybe FilePath -> Result ErrorMessage Destination +determineDestination output = + case output of + Just path -> + Ok (ToFile path) + + Nothing -> + Ok InPlace + + +determineMode : Bool -> Mode +determineMode doValidate = + if doValidate then + ValidateMode + + else + FormatMode + + +determineWhatToDo : Source -> Destination -> Mode -> Result ErrorMessage WhatToDo +determineWhatToDo source destination mode = + case ( mode, source, destination ) of + ( ValidateMode, _, ToFile _ ) -> + Err OutputAndValidate + + ( ValidateMode, Stdin, _ ) -> + Ok (Validate ValidateStdin) + + ( ValidateMode, FromFiles first rest, _ ) -> + Ok (Validate (ValidateFiles first rest)) + + ( FormatMode, Stdin, InPlace ) -> + Ok (Format StdinToStdout) + + ( FormatMode, Stdin, ToFile output ) -> + Ok (Format (StdinToFile output)) + + ( FormatMode, FromFiles first [], ToFile output ) -> + Ok (Format (FileToFile first output)) + + ( FormatMode, FromFiles first rest, InPlace ) -> + Ok (Format (FilesInPlace first rest)) + + ( _, FromFiles _ _, ToFile _ ) -> + Err SingleOutputWithMultipleInputs + + +determineWhatToDoFromConfig : Flags -> Result (List Error) (List FilePath) -> Result ErrorMessage WhatToDo +determineWhatToDoFromConfig (Flags maybeOutput _ doValidate stdin) resolvedInputFiles = + determineSource stdin resolvedInputFiles + |> Result.andThen + (\source -> + determineDestination maybeOutput + |> Result.andThen + (\destination -> + determineWhatToDo source destination (determineMode doValidate) + ) + ) + + +validate : ( FilePath, String ) -> Result InfoMessage () +validate (( inputFile, inputText ) as input) = + case format input of + Ok modu -> + if inputText /= modu then + Err (FileWouldChange inputFile) + + else + Ok () + + Err err -> + Err err + + +format : ( FilePath, String ) -> Result InfoMessage String +format ( inputFile, inputText ) = + -- FIXME fix hardcoded projectType + Common.Format.format (SV.fileSyntaxVersion inputFile) (M.Package Pkg.core) inputText + |> Result.mapError + (\_ -> + -- FIXME show errors! + -- let + -- _ = + -- Debug.log "err" err + -- in + ParseError inputFile [] + ) + + +doIt : Bool -> WhatToDo -> Task Never Bool +doIt autoYes whatToDo = + case whatToDo of + Validate validateMode -> + validateNoChanges validateMode + + Format transformMode -> + applyTransformation + ProcessingFile + autoYes + FilesWillBeOverwritten + format + transformMode + + + +-- MESSAGES + + +type InfoMessage + = ProcessingFile FilePath + | FileWouldChange FilePath + | ParseError FilePath (List (A.Located E.Error)) + | JsonParseError FilePath String + + +type PromptMessage + = FilesWillBeOverwritten (List FilePath) + + +type ErrorMessage + = BadInputFiles (List Error) + | NoInputs + | SingleOutputWithMultipleInputs + | TooManyInputs + | OutputAndValidate + + +showFiles : List FilePath -> String +showFiles = + unlines << List.map (\filename -> " " ++ filename) + + +toConsolePromptMessage : PromptMessage -> String +toConsolePromptMessage promptMessage = + case promptMessage of + FilesWillBeOverwritten filePaths -> + unlines + [ "This will overwrite the following files to use Elm's preferred style:" + , "" + , showFiles filePaths + , "This cannot be undone! Make sure to back up these files before proceeding." + , "" + , "Are you sure you want to overwrite these files with formatted versions? (y/n)" + ] + + +toConsoleInfoMessage : InfoMessage -> String +toConsoleInfoMessage infoMessage = + case infoMessage of + ProcessingFile file -> + "Processing file " ++ file + + FileWouldChange file -> + "File would be changed " ++ file + + ParseError inputFile errs -> + let + location : FilePath + location = + case errs of + [] -> + inputFile + + (A.At (A.Region (A.Position line col) _) _) :: _ -> + inputFile ++ ":" ++ String.fromInt line ++ ":" ++ String.fromInt col + in + "Unable to parse file " ++ location ++ " To see a detailed explanation, run elm make on the file." + + JsonParseError inputFile err -> + "Unable to parse JSON file " ++ inputFile ++ "\n\n" ++ err + + +jsonInfoMessage : InfoMessage -> Maybe Encode.Value +jsonInfoMessage infoMessage = + let + fileMessage : String -> String -> Encode.Value + fileMessage filename message = + Encode.object + [ ( "path", Encode.string filename ) + , ( "message", Encode.string message ) + ] + in + case infoMessage of + ProcessingFile _ -> + Nothing + + FileWouldChange file -> + Just (fileMessage file "File is not formatted with elm-format-0.8.7 --elm-version=0.19") + + ParseError inputFile _ -> + Just (fileMessage inputFile "Error parsing the file") + + JsonParseError inputFile _ -> + Just (fileMessage inputFile "Error parsing the JSON file") + + +toConsoleErrorMessage : ErrorMessage -> String +toConsoleErrorMessage errorMessage = + case errorMessage of + BadInputFiles filePaths -> + unlines + [ "There was a problem reading one or more of the specified INPUT paths:" + , "" + , unlines (List.map (\fp -> " " ++ toConsoleError fp) filePaths) + , "Please check the given paths." + ] + + SingleOutputWithMultipleInputs -> + unlines + [ "Can't write to the OUTPUT path, because multiple .elm files have been specified." + , "" + , "Please remove the --output argument. The .elm files in INPUT will be formatted in place." + ] + + TooManyInputs -> + "Too many input sources! Please only provide one of either INPUT or --stdin" + + OutputAndValidate -> + "Cannot use --output and --validate together" + + NoInputs -> + "No file inputs provided. Use the --stdin flag to format input from standard input." + + + +-- COMMAND LINE + + +type FileType + = IsFile + | IsDirectory + | DoesNotExist + + +readUtf8FileWithPath : FilePath -> Task Never ( FilePath, String ) +readUtf8FileWithPath filePath = + File.readUtf8 filePath + |> Task.fmap (Tuple.pair filePath) + + +stat : FilePath -> Task Never FileType +stat path = + Utils.dirDoesFileExist path + |> Task.bind + (\isFile -> + Utils.dirDoesDirectoryExist path + |> Task.fmap + (\isDirectory -> + case ( isFile, isDirectory ) of + ( True, _ ) -> + IsFile + + ( _, True ) -> + IsDirectory + + ( False, False ) -> + DoesNotExist + ) + ) + + +getYesOrNo : Task Never Bool +getYesOrNo = + IO.hFlush IO.stdout + |> Task.bind + (\_ -> + IO.getLine + |> Task.bind + (\input -> + case input of + "y" -> + Task.pure True + + "n" -> + Task.pure False + + _ -> + IO.putStr "Must type 'y' for yes or 'n' for no: " + |> Task.bind (\_ -> getYesOrNo) + ) + ) + + +type ValidateMode + = ValidateStdin + | ValidateFiles FilePath (List FilePath) + + + +-- INFO FORMATTER + + +approve : Bool -> PromptMessage -> Task Never Bool +approve autoYes prompt = + if autoYes then + Task.pure True + + else + putStrLn False (toConsolePromptMessage prompt) + |> Task.bind (\_ -> getYesOrNo) + + +putStrLn : Bool -> String -> Task Never () +putStrLn usingStdout = + -- we log to stdout unless it is being used for file output (in that case, we log to stderr) + if usingStdout then + IO.hPutStrLn IO.stderr + + else + IO.putStrLn + + +resultsToJsonString : List (Result (Maybe String) ()) -> String +resultsToJsonString results = + let + lines : List String + lines = + List.filterMap handleResult results + + handleResult : Result (Maybe String) () -> Maybe String + handleResult result = + case result of + Err info -> + info + + Ok () -> + Nothing + in + if List.isEmpty lines then + "[]" + + else + "[" ++ String.join "\n," lines ++ "\n]" + + + +-- RESOLVE FILES + + +type Error + = FileDoesNotExist FilePath + | NoElmFiles FilePath + + +toConsoleError : Error -> String +toConsoleError error = + case error of + FileDoesNotExist path -> + path ++ ": No such file or directory" + + NoElmFiles path -> + path ++ ": Directory does not contain any *.elm files" + + +resolveFile : FilePath -> Task Never (Result Error (List FilePath)) +resolveFile path = + stat path + |> Task.bind + (\fileType -> + case fileType of + IsFile -> + Task.pure (Ok [ path ]) + + IsDirectory -> + findAllElmFiles path + |> Task.fmap + (\elmFiles -> + case elmFiles of + [] -> + Err (NoElmFiles path) + + _ -> + Ok elmFiles + ) + + DoesNotExist -> + Task.pure (Err (FileDoesNotExist path)) + ) + + +resolveElmFiles : List FilePath -> Task Never (Result (List Error) (List FilePath)) +resolveElmFiles inputFiles = + Task.mapM resolveFile inputFiles + |> Task.fmap collectErrors + |> Task.fmap + (\result -> + case result of + Err ls -> + Err ls + + Ok files -> + Ok (List.concat files) + ) + + +collectErrors : List (Result e v) -> Result (List e) (List v) +collectErrors = + List.foldl + (\next acc -> + case ( next, acc ) of + ( Err e, Ok _ ) -> + Err [ e ] + + ( Err e, Err es ) -> + Err (e :: es) + + ( Ok v, Ok vs ) -> + Ok (v :: vs) + + ( Ok _, Err es ) -> + Err es + ) + (Ok []) + + + +-- TRANSFORM FILES + + +type TranformFilesResult a + = NoChange FilePath a + | Changed FilePath a + + +updateFile : TranformFilesResult String -> Task Never () +updateFile result = + case result of + NoChange _ _ -> + Task.pure () + + Changed outputFile outputText -> + File.writeUtf8 outputFile outputText + + +readStdin : Task Never ( FilePath, String ) +readStdin = + File.readStdin + |> Task.fmap (Tuple.pair "") + + +checkChange : ( FilePath, a ) -> a -> TranformFilesResult a +checkChange ( inputFile, inputText ) outputText = + if inputText == outputText then + NoChange inputFile outputText + + else + Changed inputFile outputText + + +readFromFile : (FilePath -> Task Never ()) -> FilePath -> Task Never ( FilePath, String ) +readFromFile onProcessingFile filePath = + onProcessingFile filePath + |> Task.bind (\_ -> readUtf8FileWithPath filePath) + + +type TransformMode + = StdinToStdout + | StdinToFile FilePath + | FileToStdout FilePath + | FileToFile FilePath FilePath + | FilesInPlace FilePath (List FilePath) + + +applyTransformation : (FilePath -> InfoMessage) -> Bool -> (List FilePath -> PromptMessage) -> (( FilePath, String ) -> Result InfoMessage String) -> TransformMode -> Task Never Bool +applyTransformation processingFile autoYes confirmPrompt transform mode = + let + usesStdout : Bool + usesStdout = + case mode of + StdinToStdout -> + True + + StdinToFile _ -> + True + + FileToStdout _ -> + True + + FileToFile _ _ -> + False + + FilesInPlace _ _ -> + False + + onInfo : InfoMessage -> Task Never () + onInfo info = + if usesStdout then + IO.hPutStrLn IO.stderr (toConsoleInfoMessage info) + + else + IO.putStrLn (toConsoleInfoMessage info) + in + case mode of + StdinToStdout -> + readStdin + |> Task.bind (logErrorOr onInfo IO.putStr << transform) + + StdinToFile outputFile -> + readStdin + |> Task.bind (logErrorOr onInfo (File.writeUtf8 outputFile) << transform) + + FileToStdout inputFile -> + readUtf8FileWithPath inputFile + |> Task.bind (logErrorOr onInfo IO.putStr << transform) + + FileToFile inputFile outputFile -> + readFromFile (onInfo << processingFile) inputFile + |> Task.bind (logErrorOr onInfo (File.writeUtf8 outputFile) << transform) + + FilesInPlace first rest -> + let + formatFile : FilePath -> Task Never Bool + formatFile file = + readFromFile (onInfo << processingFile) file + |> Task.bind (\i -> logErrorOr onInfo updateFile <| Result.map (checkChange i) (transform i)) + in + approve autoYes (confirmPrompt (first :: rest)) + |> Task.bind + (\canOverwrite -> + if canOverwrite then + Task.mapM formatFile (first :: rest) + |> Task.fmap (List.all identity) + + else + Task.pure True + ) + + +validateNoChanges : ValidateMode -> Task Never Bool +validateNoChanges mode = + let + newValidate : FilePath -> String -> Result (Maybe String) () + newValidate filePath content = + case validate ( filePath, content ) of + Err info -> + Err (Maybe.map (Encode.encode 0) (jsonInfoMessage info)) + + Ok value -> + Ok value + in + case mode of + ValidateStdin -> + readStdin + |> Task.bind + (\( filePath, content ) -> + let + result : Result (Maybe String) () + result = + newValidate filePath content + in + IO.putStrLn (resultsToJsonString [ result ]) + |> Task.fmap (\_ -> Result.isOk result) + ) + + ValidateFiles first rest -> + let + validateFile : FilePath -> Task Never (Result (Maybe String) ()) + validateFile filePath = + File.readUtf8 filePath + |> Task.fmap (newValidate filePath) + in + Task.mapM validateFile (first :: rest) + |> Task.bind + (\results -> + IO.putStrLn (resultsToJsonString results) + |> Task.fmap (\_ -> List.all Result.isOk results) + ) + + +logErrorOr : (error -> Task Never ()) -> (a -> Task Never ()) -> Result error a -> Task Never Bool +logErrorOr onInfo fn result = + case result of + Err message -> + onInfo message + |> Task.fmap (\_ -> False) + + Ok value -> + fn value + |> Task.fmap (\_ -> True) + + + +-- FILESYSTEM + + +collectFiles : (a -> Task Never (List a)) -> a -> Task Never (List a) +collectFiles children root = + children root + |> Task.bind (\xs -> Task.mapM (collectFiles children) xs) + |> Task.fmap (\subChildren -> root :: List.concat subChildren) + + +listDir : FilePath -> Task Never (List FilePath) +listDir path = + Utils.dirListDirectory path + |> Task.fmap (List.map (\file -> path ++ "/" ++ file)) + + +fileList : FilePath -> Task Never (List FilePath) +fileList = + let + children : FilePath -> Task Never (List FilePath) + children path = + if isSkippable path then + Task.pure [] + + else + Utils.dirDoesDirectoryExist path + |> Task.bind + (\directory -> + if directory then + listDir path + + else + Task.pure [] + ) + in + collectFiles children + + +isSkippable : FilePath -> Bool +isSkippable path = + List.any identity + [ hasFilename "elm-stuff" path + , hasFilename "node_modules" path + , hasFilename ".git" path + ] + + +hasExtension : String -> FilePath -> Bool +hasExtension ext path = + ext == Utils.fpTakeExtension path + + +findAllElmFiles : FilePath -> Task Never (List FilePath) +findAllElmFiles inputFile = + fileList inputFile + |> Task.fmap (List.filter (hasExtension ".elm")) + + +hasFilename : String -> FilePath -> Bool +hasFilename name path = + name == Utils.fpTakeFileName path + + + +-- PRELUDE + + +unlines : List String -> String +unlines = + List.map (\line -> line ++ "\n") + >> String.concat diff --git a/src/Terminal/Init.elm b/src/Terminal/Init.elm new file mode 100644 index 0000000000..649e8c5fa4 --- /dev/null +++ b/src/Terminal/Init.elm @@ -0,0 +1,274 @@ +module Terminal.Init exposing + ( Flags(..) + , run + ) + +import Basics.Extra exposing (flip) +import Builder.Deps.Registry as Registry +import Builder.Deps.Solver as Solver +import Builder.Elm.Outline as Outline +import Builder.File as File +import Builder.Reporting as Reporting +import Builder.Reporting.Exit as Exit +import Builder.Reporting.Exit.Help as Help +import Builder.Stuff as Stuff +import Compiler.Data.NonEmptyList as NE +import Compiler.Elm.Constraint as Con +import Compiler.Elm.Licenses as Licenses +import Compiler.Elm.Package as Pkg +import Compiler.Elm.Version as V +import Compiler.Reporting.Doc as D +import Data.Map as Dict exposing (Dict) +import System.IO as IO +import Task exposing (Task) +import Utils.Main as Utils +import Utils.Task.Extra as Task + + + +-- RUN + + +type Flags + = Flags Bool Bool + + +run : () -> Flags -> Task Never () +run () (Flags package autoYes) = + Reporting.attempt Exit.initToReport <| + (Utils.dirDoesFileExist "elm.json" + |> Task.bind + (\exists -> + if exists then + Task.pure (Err Exit.InitAlreadyExists) + + else + let + askQuestion : Task Never Bool + askQuestion = + if autoYes then + Help.toStdout (information [ D.fromChars "" ]) + |> Task.fmap (\_ -> True) + + else + Reporting.ask + (information + [ D.fromChars "Knowing all that, would you like me to create an elm.json file now? [Y/n]: " + ] + ) + in + askQuestion + |> Task.bind + (\approved -> + if approved then + init package + + else + IO.putStrLn "Okay, I did not make any changes!" + |> Task.fmap (\_ -> Ok ()) + ) + ) + ) + + +information : List D.Doc -> D.Doc +information question = + D.stack + (D.fillSep + [ D.fromChars "Hello!" + , D.fromChars "Elm" + , D.fromChars "projects" + , D.fromChars "always" + , D.fromChars "start" + , D.fromChars "with" + , D.fromChars "an" + , D.green (D.fromChars "elm.json") + , D.fromChars "file." + , D.fromChars "I" + , D.fromChars "can" + , D.fromChars "create" + , D.fromChars "them!" + ] + :: D.reflow "Now you may be wondering, what will be in this file? How do I add Elm files to my project? How do I see it in the browser? How will my code grow? Do I need more directories? What about tests? Etc." + :: D.fillSep + [ D.fromChars "Check" + , D.fromChars "out" + , D.cyan (D.fromChars (D.makeLink "init")) + , D.fromChars "for" + , D.fromChars "all" + , D.fromChars "the" + , D.fromChars "answers!" + ] + :: question + ) + + + +-- INIT + + +init : Bool -> Task Never (Result Exit.Init ()) +init package = + Solver.initEnv + |> Task.bind + (\eitherEnv -> + case eitherEnv of + Err problem -> + Task.pure (Err (Exit.InitRegistryProblem problem)) + + Ok (Solver.Env cache _ connection registry) -> + verify cache connection registry defaults <| + \details -> + verify cache connection registry testDefaults <| + \testDetails -> + Utils.dirCreateDirectoryIfMissing True "src" + |> Task.bind (\_ -> Utils.dirCreateDirectoryIfMissing True "tests") + |> Task.bind (\_ -> File.writeUtf8 "tests/Example.elm" testExample) + |> Task.bind + (\_ -> + let + outline : Outline.Outline + outline = + if package then + let + directs : Dict ( String, String ) Pkg.Name Con.Constraint + directs = + Dict.map + (\pkg _ -> + let + (Solver.Details vsn _) = + Utils.find identity pkg details + in + Con.untilNextMajor vsn + ) + packageDefaults + + testDirects : Dict ( String, String ) Pkg.Name Con.Constraint + testDirects = + Dict.map + (\pkg _ -> + let + (Solver.Details vsn _) = + Utils.find identity pkg testDetails + in + Con.untilNextMajor vsn + ) + packageTestDefaults + in + Outline.Pkg <| + Outline.PkgOutline + Pkg.dummyName + Outline.defaultSummary + Licenses.bsd3 + V.one + (Outline.ExposedList []) + directs + testDirects + Con.defaultElm + + else + let + solution : Dict ( String, String ) Pkg.Name V.Version + solution = + Dict.map (\_ (Solver.Details vsn _) -> vsn) details + + directs : Dict ( String, String ) Pkg.Name V.Version + directs = + Dict.intersection compare solution defaults + + indirects : Dict ( String, String ) Pkg.Name V.Version + indirects = + Dict.diff solution defaults + + testSolution : Dict ( String, String ) Pkg.Name V.Version + testSolution = + Dict.map (\_ (Solver.Details vsn _) -> vsn) testDetails + + testDirects : Dict ( String, String ) Pkg.Name V.Version + testDirects = + Dict.intersection compare testSolution testDefaults + + testIndirects : Dict ( String, String ) Pkg.Name V.Version + testIndirects = + Dict.diff testSolution testDefaults + |> flip Dict.diff directs + |> flip Dict.diff indirects + in + Outline.App <| + Outline.AppOutline V.elmCompiler + (NE.Nonempty (Outline.RelativeSrcDir "src") []) + directs + indirects + testDirects + testIndirects + in + Outline.write "." outline + ) + |> Task.bind (\_ -> IO.putStrLn "Okay, I created it. Now read that link!") + |> Task.fmap (\_ -> Ok ()) + ) + + +verify : Stuff.PackageCache -> Solver.Connection -> Registry.Registry -> Dict ( String, String ) Pkg.Name Con.Constraint -> (Dict ( String, String ) Pkg.Name Solver.Details -> Task Never (Result Exit.Init ())) -> Task Never (Result Exit.Init ()) +verify cache connection registry constraints callback = + Solver.verify cache connection registry constraints + |> Task.bind + (\result -> + case result of + Solver.SolverErr exit -> + Task.pure (Err (Exit.InitSolverProblem exit)) + + Solver.NoSolution -> + Task.pure (Err (Exit.InitNoSolution (Dict.keys compare constraints))) + + Solver.NoOfflineSolution -> + Task.pure (Err (Exit.InitNoOfflineSolution (Dict.keys compare constraints))) + + Solver.SolverOk details -> + callback details + ) + + +defaults : Dict ( String, String ) Pkg.Name Con.Constraint +defaults = + Dict.fromList identity + [ ( Pkg.core, Con.anything ) + , ( Pkg.browser, Con.anything ) + , ( Pkg.html, Con.anything ) + ] + + +testDefaults : Dict ( String, String ) Pkg.Name Con.Constraint +testDefaults = + Dict.fromList identity + [ ( Pkg.test, Con.anything ) + ] + + +packageDefaults : Dict ( String, String ) Pkg.Name Con.Constraint +packageDefaults = + Dict.fromList identity + [ ( Pkg.core, Con.anything ) + ] + + +packageTestDefaults : Dict ( String, String ) Pkg.Name Con.Constraint +packageTestDefaults = + Dict.fromList identity + [ ( Pkg.test, Con.anything ) + ] + + +testExample : String +testExample = + """module Example exposing (..) + +import Expect exposing (Expectation) +import Fuzz exposing (Fuzzer, int, list, string) +import Test exposing (..) + + +suite : Test +suite = + todo "Implement our first test. See https://package.elm-lang.org/packages/elm-explorations/test/latest for how to do this!" +""" diff --git a/src/Terminal/Install.elm b/src/Terminal/Install.elm new file mode 100644 index 0000000000..c45d09d72d --- /dev/null +++ b/src/Terminal/Install.elm @@ -0,0 +1,684 @@ +module Terminal.Install exposing + ( Args(..) + , Flags(..) + , run + ) + +import Builder.BackgroundWriter as BW +import Builder.Deps.Registry as Registry +import Builder.Deps.Solver as Solver +import Builder.Elm.Details as Details +import Builder.Elm.Outline as Outline +import Builder.Reporting as Reporting +import Builder.Reporting.Exit as Exit +import Builder.Stuff as Stuff +import Compiler.Elm.Constraint as C +import Compiler.Elm.Package as Pkg +import Compiler.Elm.Version as V +import Compiler.Reporting.Doc as D +import Data.Map as Dict exposing (Dict) +import System.IO as IO +import Task exposing (Task) +import Utils.Main as Utils exposing (FilePath) +import Utils.Task.Extra as Task + + + +-- RUN + + +type Args + = NoArgs + | Install Pkg.Name + + +type Flags + = Flags Bool Bool + + +run : Args -> Flags -> Task Never () +run args (Flags forTest autoYes) = + Reporting.attempt Exit.installToReport + (Stuff.findRoot + |> Task.bind + (\maybeRoot -> + case maybeRoot of + Nothing -> + Task.pure (Err Exit.InstallNoOutline) + + Just root -> + case args of + NoArgs -> + Stuff.getElmHome + |> Task.fmap (\elmHome -> Err (Exit.InstallNoArgs elmHome)) + + Install pkg -> + Task.run + (Task.eio Exit.InstallBadRegistry Solver.initEnv + |> Task.bind + (\env -> + Task.eio Exit.InstallBadOutline (Outline.read root) + |> Task.bind + (\oldOutline -> + case oldOutline of + Outline.App outline -> + makeAppPlan env pkg outline forTest + |> Task.bind (\changes -> attemptChanges root env oldOutline V.toChars changes autoYes) + + Outline.Pkg outline -> + makePkgPlan env pkg outline forTest + |> Task.bind (\changes -> attemptChanges root env oldOutline C.toChars changes autoYes) + ) + ) + ) + ) + ) + + + +-- ATTEMPT CHANGES + + +type Changes vsn + = AlreadyInstalled + | PromoteTest Outline.Outline + | PromoteIndirect Outline.Outline + | Changes (Dict ( String, String ) Pkg.Name (Change vsn)) Outline.Outline + + +attemptChanges : String -> Solver.Env -> Outline.Outline -> (a -> String) -> Changes a -> Bool -> Task Exit.Install () +attemptChanges root env oldOutline toChars changes autoYes = + case changes of + AlreadyInstalled -> + Task.io (IO.putStrLn "It is already installed!") + + PromoteIndirect newOutline -> + attemptChangesHelp root env oldOutline newOutline autoYes <| + D.vcat + [ D.fillSep + [ D.fromChars "I" + , D.fromChars "found" + , D.fromChars "it" + , D.fromChars "in" + , D.fromChars "your" + , D.fromChars "elm.json" + , D.fromChars "file," + , D.fromChars "but" + , D.fromChars "in" + , D.fromChars "the" + , D.dullyellow (D.fromChars "\"indirect\"") + , D.fromChars "dependencies." + ] + , D.fillSep + [ D.fromChars "Should" + , D.fromChars "I" + , D.fromChars "move" + , D.fromChars "it" + , D.fromChars "into" + , D.green (D.fromChars "\"direct\"") + , D.fromChars "dependencies" + , D.fromChars "for" + , D.fromChars "more" + , D.fromChars "general" + , D.fromChars "use?" + , D.fromChars "[Y/n]: " + ] + ] + + PromoteTest newOutline -> + attemptChangesHelp root env oldOutline newOutline autoYes <| + D.vcat + [ D.fillSep + [ D.fromChars "I" + , D.fromChars "found" + , D.fromChars "it" + , D.fromChars "in" + , D.fromChars "your" + , D.fromChars "elm.json" + , D.fromChars "file," + , D.fromChars "but" + , D.fromChars "in" + , D.fromChars "the" + , D.dullyellow (D.fromChars "\"test-dependencies\"") + , D.fromChars "field." + ] + , D.fillSep + [ D.fromChars "Should" + , D.fromChars "I" + , D.fromChars "move" + , D.fromChars "it" + , D.fromChars "into" + , D.green (D.fromChars "\"dependencies\"") + , D.fromChars "for" + , D.fromChars "more" + , D.fromChars "general" + , D.fromChars "use?" + , D.fromChars "[Y/n]: " + ] + ] + + Changes changeDict newOutline -> + let + widths : Widths + widths = + Dict.foldr compare (widen toChars) (Widths 0 0 0) changeDict + + changeDocs : ChangeDocs + changeDocs = + Dict.foldr compare (addChange toChars widths) (Docs [] [] []) changeDict + in + attemptChangesHelp root env oldOutline newOutline autoYes <| + D.vcat + [ D.fromChars "Here is my plan:" + , viewChangeDocs changeDocs + , D.fromChars "" + , D.fromChars "Would you like me to update your elm.json accordingly? [Y/n]: " + ] + + +attemptChangesHelp : FilePath -> Solver.Env -> Outline.Outline -> Outline.Outline -> Bool -> D.Doc -> Task Exit.Install () +attemptChangesHelp root env oldOutline newOutline autoYes question = + Task.eio Exit.InstallBadDetails <| + BW.withScope + (\scope -> + let + askQuestion : Task Never Bool + askQuestion = + if autoYes then + Task.pure True + + else + Reporting.ask question + in + askQuestion + |> Task.bind + (\approved -> + if approved then + Outline.write root newOutline + |> Task.bind (\_ -> Details.verifyInstall scope root env newOutline) + |> Task.bind + (\result -> + case result of + Err exit -> + Outline.write root oldOutline + |> Task.fmap (\_ -> Err exit) + + Ok () -> + IO.putStrLn "Success!" + |> Task.fmap (\_ -> Ok ()) + ) + + else + IO.putStrLn "Okay, I did not change anything!" + |> Task.fmap (\_ -> Ok ()) + ) + ) + + + +-- MAKE APP PLAN + + +makeAppPlan : Solver.Env -> Pkg.Name -> Outline.AppOutline -> Bool -> Task Exit.Install (Changes V.Version) +makeAppPlan (Solver.Env cache _ connection registry) pkg ((Outline.AppOutline elmVersion sourceDirs direct indirect testDirect testIndirect) as outline) forTest = + if forTest then + if Dict.member identity pkg testDirect then + Task.pure AlreadyInstalled + + else + (-- is it already an indirect test dependency? + case Dict.get identity pkg testIndirect of + Just vsn -> + Task.pure <| + PromoteTest <| + Outline.App <| + Outline.AppOutline elmVersion + sourceDirs + direct + indirect + (Dict.insert identity pkg vsn testDirect) + (Dict.remove identity pkg testIndirect) + + Nothing -> + -- finally try to add it from scratch + case Registry.getVersions_ pkg registry of + Err suggestions -> + case connection of + Solver.Online _ -> + Task.throw (Exit.InstallUnknownPackageOnline pkg suggestions) + + Solver.Offline -> + Task.throw (Exit.InstallUnknownPackageOffline pkg suggestions) + + Ok _ -> + Task.io (Solver.addToApp cache connection registry pkg outline forTest) + |> Task.bind + (\result -> + case result of + Solver.SolverOk (Solver.AppSolution old new app) -> + Task.pure (Changes (detectChanges old new) (Outline.App app)) + + Solver.NoSolution -> + Task.throw (Exit.InstallNoOnlineAppSolution pkg) + + Solver.NoOfflineSolution -> + Task.throw (Exit.InstallNoOfflineAppSolution pkg) + + Solver.SolverErr exit -> + Task.throw (Exit.InstallHadSolverTrouble exit) + ) + ) + + else if Dict.member identity pkg direct then + Task.pure AlreadyInstalled + + else + -- is it already indirect? + case Dict.get identity pkg indirect of + Just vsn -> + Task.pure <| + PromoteIndirect <| + Outline.App <| + Outline.AppOutline elmVersion + sourceDirs + (Dict.insert identity pkg vsn direct) + (Dict.remove identity pkg indirect) + testDirect + testIndirect + + Nothing -> + -- is it already a test dependency? + case Dict.get identity pkg testDirect of + Just vsn -> + Task.pure <| + PromoteTest <| + Outline.App <| + Outline.AppOutline elmVersion + sourceDirs + (Dict.insert identity pkg vsn direct) + indirect + (Dict.remove identity pkg testDirect) + testIndirect + + Nothing -> + -- is it already an indirect test dependency? + case Dict.get identity pkg testIndirect of + Just vsn -> + Task.pure <| + PromoteTest <| + Outline.App <| + Outline.AppOutline elmVersion + sourceDirs + (Dict.insert identity pkg vsn direct) + indirect + testDirect + (Dict.remove identity pkg testIndirect) + + Nothing -> + -- finally try to add it from scratch + case Registry.getVersions_ pkg registry of + Err suggestions -> + case connection of + Solver.Online _ -> + Task.throw (Exit.InstallUnknownPackageOnline pkg suggestions) + + Solver.Offline -> + Task.throw (Exit.InstallUnknownPackageOffline pkg suggestions) + + Ok _ -> + Task.io (Solver.addToApp cache connection registry pkg outline forTest) + |> Task.bind + (\result -> + case result of + Solver.SolverOk (Solver.AppSolution old new app) -> + Task.pure (Changes (detectChanges old new) (Outline.App app)) + + Solver.NoSolution -> + Task.throw (Exit.InstallNoOnlineAppSolution pkg) + + Solver.NoOfflineSolution -> + Task.throw (Exit.InstallNoOfflineAppSolution pkg) + + Solver.SolverErr exit -> + Task.throw (Exit.InstallHadSolverTrouble exit) + ) + + + +-- MAKE PACKAGE PLAN + + +makePkgPlan : Solver.Env -> Pkg.Name -> Outline.PkgOutline -> Bool -> Task Exit.Install (Changes C.Constraint) +makePkgPlan (Solver.Env cache _ connection registry) pkg (Outline.PkgOutline name summary license version exposed deps test elmVersion) forTest = + if forTest then + if Dict.member identity pkg test then + Task.pure AlreadyInstalled + + else + -- try to add a new dependency + case Registry.getVersions_ pkg registry of + Err suggestions -> + case connection of + Solver.Online _ -> + Task.throw (Exit.InstallUnknownPackageOnline pkg suggestions) + + Solver.Offline -> + Task.throw (Exit.InstallUnknownPackageOffline pkg suggestions) + + Ok (Registry.KnownVersions _ _) -> + let + cons : Dict ( String, String ) Pkg.Name C.Constraint + cons = + Dict.insert identity pkg C.anything test + in + Task.io (Solver.verify cache connection registry cons) + |> Task.bind + (\result -> + case result of + Solver.SolverOk solution -> + let + (Solver.Details vsn _) = + Utils.find identity pkg solution + + con : C.Constraint + con = + C.untilNextMajor vsn + + newTest : Dict ( String, String ) Pkg.Name C.Constraint + newTest = + Dict.insert identity pkg con test + + changes : Dict ( String, String ) Pkg.Name (Change C.Constraint) + changes = + detectChanges test newTest + + news : Dict ( String, String ) Pkg.Name C.Constraint + news = + Utils.mapMapMaybe identity Pkg.compareName keepNew changes + in + Task.pure <| + Changes changes <| + Outline.Pkg <| + Outline.PkgOutline name + summary + license + version + exposed + deps + (addNews (Just pkg) news test) + elmVersion + + Solver.NoSolution -> + Task.throw (Exit.InstallNoOnlinePkgSolution pkg) + + Solver.NoOfflineSolution -> + Task.throw (Exit.InstallNoOfflinePkgSolution pkg) + + Solver.SolverErr exit -> + Task.throw (Exit.InstallHadSolverTrouble exit) + ) + + else if Dict.member identity pkg deps then + Task.pure AlreadyInstalled + + else + -- is already in test dependencies? + case Dict.get identity pkg test of + Just con -> + Task.pure <| + PromoteTest <| + Outline.Pkg <| + Outline.PkgOutline name + summary + license + version + exposed + (Dict.insert identity pkg con deps) + (Dict.remove identity pkg test) + elmVersion + + Nothing -> + -- try to add a new dependency + case Registry.getVersions_ pkg registry of + Err suggestions -> + case connection of + Solver.Online _ -> + Task.throw (Exit.InstallUnknownPackageOnline pkg suggestions) + + Solver.Offline -> + Task.throw (Exit.InstallUnknownPackageOffline pkg suggestions) + + Ok (Registry.KnownVersions _ _) -> + let + old : Dict ( String, String ) Pkg.Name C.Constraint + old = + Dict.union deps test + + cons : Dict ( String, String ) Pkg.Name C.Constraint + cons = + Dict.insert identity pkg C.anything old + in + Task.io (Solver.verify cache connection registry cons) + |> Task.bind + (\result -> + case result of + Solver.SolverOk solution -> + let + (Solver.Details vsn _) = + Utils.find identity pkg solution + + con : C.Constraint + con = + C.untilNextMajor vsn + + new : Dict ( String, String ) Pkg.Name C.Constraint + new = + Dict.insert identity pkg con old + + changes : Dict ( String, String ) Pkg.Name (Change C.Constraint) + changes = + detectChanges old new + + news : Dict ( String, String ) Pkg.Name C.Constraint + news = + Utils.mapMapMaybe identity Pkg.compareName keepNew changes + in + Task.pure <| + Changes changes <| + Outline.Pkg <| + Outline.PkgOutline name + summary + license + version + exposed + (addNews (Just pkg) news deps) + (addNews Nothing news test) + elmVersion + + Solver.NoSolution -> + Task.throw (Exit.InstallNoOnlinePkgSolution pkg) + + Solver.NoOfflineSolution -> + Task.throw (Exit.InstallNoOfflinePkgSolution pkg) + + Solver.SolverErr exit -> + Task.throw (Exit.InstallHadSolverTrouble exit) + ) + + +addNews : Maybe Pkg.Name -> Dict ( String, String ) Pkg.Name C.Constraint -> Dict ( String, String ) Pkg.Name C.Constraint -> Dict ( String, String ) Pkg.Name C.Constraint +addNews pkg new old = + Dict.merge compare + (Dict.insert identity) + (\k _ n -> Dict.insert identity k n) + (\k c acc -> + if Just k == pkg then + Dict.insert identity k c acc + + else + acc + ) + old + new + Dict.empty + + + +-- CHANGES + + +type Change a + = Insert a + | Change a a + | Remove a + + +detectChanges : Dict ( String, String ) Pkg.Name a -> Dict ( String, String ) Pkg.Name a -> Dict ( String, String ) Pkg.Name (Change a) +detectChanges old new = + Dict.merge compare + (\k v -> Dict.insert identity k (Remove v)) + (\k oldElem newElem acc -> + case keepChange k oldElem newElem of + Just change -> + Dict.insert identity k change acc + + Nothing -> + acc + ) + (\k v -> Dict.insert identity k (Insert v)) + old + new + Dict.empty + + +keepChange : k -> v -> v -> Maybe (Change v) +keepChange _ old new = + if old == new then + Nothing + + else + Just (Change old new) + + +keepNew : Change a -> Maybe a +keepNew change = + case change of + Insert a -> + Just a + + Change _ a -> + Just a + + Remove _ -> + Nothing + + + +-- VIEW CHANGE DOCS + + +type ChangeDocs + = Docs (List D.Doc) (List D.Doc) (List D.Doc) + + +viewChangeDocs : ChangeDocs -> D.Doc +viewChangeDocs (Docs inserts changes removes) = + D.indent 2 <| + D.vcat <| + List.concat <| + [ viewNonZero "Add:" inserts + , viewNonZero "Change:" changes + , viewNonZero "Remove:" removes + ] + + +viewNonZero : String -> List D.Doc -> List D.Doc +viewNonZero title entries = + if List.isEmpty entries then + [] + + else + [ D.fromChars "" + , D.fromChars title + , D.indent 2 (D.vcat entries) + ] + + + +-- VIEW CHANGE + + +addChange : (a -> String) -> Widths -> Pkg.Name -> Change a -> ChangeDocs -> ChangeDocs +addChange toChars widths name change (Docs inserts changes removes) = + case change of + Insert new -> + Docs (viewInsert toChars widths name new :: inserts) changes removes + + Change old new -> + Docs inserts (viewChange toChars widths name old new :: changes) removes + + Remove old -> + Docs inserts changes (viewRemove toChars widths name old :: removes) + + +viewInsert : (a -> String) -> Widths -> Pkg.Name -> a -> D.Doc +viewInsert toChars (Widths nameWidth leftWidth _) name new = + viewName nameWidth name + |> D.plus (pad leftWidth (toChars new)) + + +viewChange : (a -> String) -> Widths -> Pkg.Name -> a -> a -> D.Doc +viewChange toChars (Widths nameWidth leftWidth rightWidth) name old new = + D.hsep + [ viewName nameWidth name + , pad leftWidth (toChars old) + , D.fromChars "=>" + , pad rightWidth (toChars new) + ] + + +viewRemove : (a -> String) -> Widths -> Pkg.Name -> a -> D.Doc +viewRemove toChars (Widths nameWidth leftWidth _) name old = + viewName nameWidth name + |> D.plus (pad leftWidth (toChars old)) + + +viewName : Int -> Pkg.Name -> D.Doc +viewName width name = + D.fill (width + 3) (D.fromPackage name) + + +pad : Int -> String -> D.Doc +pad width string = + D.fromChars (String.repeat (width - String.length string) " ") + |> D.a (D.fromChars string) + + + +-- WIDTHS + + +type Widths + = Widths Int Int Int + + +widen : (a -> String) -> Pkg.Name -> Change a -> Widths -> Widths +widen toChars pkg change (Widths name left right) = + let + toLength : a -> Int + toLength a = + String.length (toChars a) + + newName : Int + newName = + max name (String.length (Pkg.toChars pkg)) + in + case change of + Insert new -> + Widths newName (max left (toLength new)) right + + Change old new -> + Widths newName (max left (toLength old)) (max right (toLength new)) + + Remove old -> + Widths newName (max left (toLength old)) right diff --git a/src/Terminal/Main.elm b/src/Terminal/Main.elm new file mode 100644 index 0000000000..bf36941b0e --- /dev/null +++ b/src/Terminal/Main.elm @@ -0,0 +1,670 @@ +module Terminal.Main exposing (main) + +import Compiler.Elm.Version as V +import Compiler.Reporting.Doc as D +import System.IO as IO +import Task exposing (Task) +import Terminal.Bump as Bump +import Terminal.Diff as Diff +import Terminal.Format as Format +import Terminal.Init as Init +import Terminal.Install as Install +import Terminal.Make as Make +import Terminal.Publish as Publish +import Terminal.Repl as Repl +import Terminal.Terminal as Terminal +import Terminal.Terminal.Chomp as Chomp +import Terminal.Terminal.Helpers as Terminal +import Terminal.Terminal.Internal as Terminal +import Terminal.Test as Test +import Terminal.Uninstall as Uninstall +import Utils.Impure as Impure +import Utils.Task.Extra as Task + + +main : IO.Program +main = + IO.run + (app + |> Task.bind + (\() -> + Impure.task "exitWith" + [] + (Impure.StringBody "0") + Impure.Crash + ) + ) + + +app : Task Never () +app = + Terminal.app intro + outro + [ repl + , init + , make + , install + , uninstall + , bump + , diff + , publish + , format + , test + ] + + +intro : D.Doc +intro = + D.vcat + [ D.fillSep + [ D.fromChars "Hi," + , D.fromChars "thank" + , D.fromChars "you" + , D.fromChars "for" + , D.fromChars "trying" + , D.fromChars "out" + , D.green (D.fromChars "Elm") + , D.green (D.fromChars (V.toChars V.compiler)) + |> D.a (D.fromChars ".") + , D.fromChars "I hope you like it!" + ] + , D.fromChars "" + , D.black (D.fromChars "-------------------------------------------------------------------------------") + , D.black (D.fromChars "I highly recommend working through to get started.") + , D.black (D.fromChars "It teaches many important concepts, including how to use `elm` in the terminal.") + , D.black (D.fromChars "-------------------------------------------------------------------------------") + ] + + +outro : D.Doc +outro = + D.fillSep <| + (List.map D.fromChars <| + String.words <| + "Be sure to ask on the Elm slack if you run into trouble! Folks are friendly and happy to help out. They hang out there because it is fun, so be kind to get the best results!" + ) + + + +-- INIT + + +init : Terminal.Command +init = + let + summary : String + summary = + "Start an Elm project. It creates a starter elm.json file and provides a link explaining what to do from there." + + details : String + details = + "The `init` command helps start Elm projects:" + + example : D.Doc + example = + reflow + "It will ask permission to create an elm.json file, the one thing common to all Elm projects. It also provides a link explaining what to do from there." + + initFlags : Terminal.Flags + initFlags = + Terminal.flags + |> Terminal.more (Terminal.onOff "package" "Creates a starter elm.json file for a package project.") + |> Terminal.more (Terminal.onOff "yes" "Reply 'yes' to all automated prompts.") + in + Terminal.Command "init" (Terminal.Common summary) details example Terminal.noArgs initFlags <| + \chunks -> + Chomp.chomp Nothing + chunks + [ Chomp.chompExactly (Chomp.pure ()) + ] + (Chomp.pure Init.Flags + |> Chomp.apply (Chomp.chompOnOffFlag "package") + |> Chomp.apply (Chomp.chompOnOffFlag "yes") + |> Chomp.bind + (\value -> + Chomp.checkForUnknownFlags initFlags + |> Chomp.fmap (\_ -> value) + ) + ) + |> Tuple.second + |> Result.map (\( args, flags ) -> Init.run args flags) + + + +-- REPL + + +repl : Terminal.Command +repl = + let + summary : String + summary = + "Open up an interactive programming session. Type in Elm expressions like (2 + 2) or (String.length \"test\") and see if they equal four!" + + details : String + details = + "The `repl` command opens up an interactive programming session:" + + example : D.Doc + example = + reflow + "Start working through to learn how to use this! It has a whole chapter that uses the REPL for everything, so that is probably the quickest way to get started." + + replFlags : Terminal.Flags + replFlags = + Terminal.flags + |> Terminal.more (Terminal.flag "interpreter" interpreter "Path to a alternate JS interpreter, like node or nodejs.") + |> Terminal.more (Terminal.onOff "no-colors" "Turn off the colors in the REPL. This can help if you are having trouble reading the values. Some terminals use a custom color scheme that diverges significantly from the standard ANSI colors, so another path may be to pick a more standard color scheme.") + in + Terminal.Command "repl" (Terminal.Common summary) details example Terminal.noArgs replFlags <| + \chunks -> + Chomp.chomp Nothing + chunks + [ Chomp.chompExactly (Chomp.pure ()) + ] + (Chomp.pure Repl.Flags + |> Chomp.apply (Chomp.chompNormalFlag "interpreter" interpreter Just) + |> Chomp.apply (Chomp.chompOnOffFlag "no-colors") + |> Chomp.bind + (\value -> + Chomp.checkForUnknownFlags replFlags + |> Chomp.fmap (\_ -> value) + ) + ) + |> Tuple.second + |> Result.map (\( args, flags ) -> Repl.run args flags) + + +interpreter : Terminal.Parser +interpreter = + Terminal.Parser + { singular = "interpreter" + , plural = "interpreters" + , suggest = \_ -> Task.pure [] + , examples = \_ -> Task.pure [ "node", "nodejs" ] + } + + + +-- MAKE + + +make : Terminal.Command +make = + let + details : String + details = + "The `make` command compiles Guida (and Elm) code into JS or HTML:" + + example : D.Doc + example = + stack + [ reflow "For example:" + , D.indent 4 <| D.green (D.fromChars "guida make src/Main.guida") + , reflow "This tries to compile an Guida (and Elm) file named src/Main.guida, generating an index.html file if possible." + ] + + makeFlags : Terminal.Flags + makeFlags = + Terminal.flags + |> Terminal.more (Terminal.onOff "debug" "Turn on the time-travelling debugger. It allows you to rewind and replay events. The events can be imported/exported into a file, which makes for very precise bug reports!") + |> Terminal.more (Terminal.onOff "optimize" "Turn on optimizations to make code smaller and faster. For example, the compiler renames record fields to be as short as possible and unboxes values to reduce allocation.") + |> Terminal.more (Terminal.onOff "sourcemaps" "Add source maps to resulting JavaScript code.") + |> Terminal.more (Terminal.flag "output" Make.output "Specify the name of the resulting JS file. For example --output=assets/guida.js to generate the JS at assets/guida.js or --output=/dev/null to generate no output at all!") + |> Terminal.more (Terminal.flag "report" Make.reportType "You can say --report=json to get error messages as JSON. This is only really useful if you are an editor plugin. Humans should avoid it!") + |> Terminal.more (Terminal.flag "docs" Make.docsFile "Generate a JSON file of documentation for a package. Eventually it will be possible to preview docs with `reactor` because it is quite hard to deal with these JSON files directly.") + in + Terminal.Command "make" Terminal.Uncommon details example (Terminal.zeroOrMore Terminal.guidaOrElmFile) makeFlags <| + \chunks -> + Chomp.chomp Nothing + chunks + [ Chomp.chompMultiple (Chomp.pure identity) Terminal.guidaOrElmFile Terminal.parseGuidaOrElmFile + ] + (Chomp.pure Make.Flags + |> Chomp.apply (Chomp.chompOnOffFlag "debug") + |> Chomp.apply (Chomp.chompOnOffFlag "optimize") + |> Chomp.apply (Chomp.chompOnOffFlag "sourcemaps") + |> Chomp.apply (Chomp.chompNormalFlag "output" Make.output Make.parseOutput) + |> Chomp.apply (Chomp.chompNormalFlag "report" Make.reportType Make.parseReportType) + |> Chomp.apply (Chomp.chompNormalFlag "docs" Make.docsFile Make.parseDocsFile) + |> Chomp.bind + (\value -> + Chomp.checkForUnknownFlags makeFlags + |> Chomp.fmap (\_ -> value) + ) + ) + |> Tuple.second + |> Result.map (\( args, flags ) -> Make.run args flags) + + + +-- INSTALL + + +install : Terminal.Command +install = + let + details : String + details = + "The `install` command fetches packages from for use in your project:" + + example : D.Doc + example = + stack + [ reflow + "For example, if you want to get packages for HTTP and JSON, you would say:" + , D.indent 4 <| + D.green <| + D.vcat <| + [ D.fromChars "guida install elm/http" + , D.fromChars "guida install elm/json" + ] + , reflow + "Notice that you must say the AUTHOR name and PROJECT name! After running those commands, you could say `import Http` or `import Json.Decode` in your code." + , reflow + "What if two projects use different versions of the same package? No problem! Each project is independent, so there cannot be conflicts like that!" + ] + + installArgs : Terminal.Args + installArgs = + Terminal.oneOf + [ Terminal.require0 + , Terminal.require1 Terminal.package + ] + + installFlags : Terminal.Flags + installFlags = + Terminal.flags + |> Terminal.more (Terminal.onOff "test" "Install as a test-dependency.") + |> Terminal.more (Terminal.onOff "yes" "Reply 'yes' to all automated prompts.") + in + Terminal.Command "install" Terminal.Uncommon details example installArgs installFlags <| + \chunks -> + Chomp.chomp Nothing + chunks + [ Chomp.chompExactly (Chomp.pure Install.NoArgs) + , Chomp.chompExactly + (Chomp.pure Install.Install + |> Chomp.bind + (\func -> + Chomp.chompArg (List.length chunks) Terminal.package Terminal.parsePackage + |> Chomp.fmap (\arg -> func arg) + ) + ) + ] + (Chomp.pure Install.Flags + |> Chomp.apply (Chomp.chompOnOffFlag "test") + |> Chomp.apply (Chomp.chompOnOffFlag "yes") + |> Chomp.bind + (\value -> + Chomp.checkForUnknownFlags installFlags + |> Chomp.fmap (\_ -> value) + ) + ) + |> Tuple.second + |> Result.map (\( args, flags ) -> Install.run args flags) + + + +-- UNINSTALL + + +uninstall : Terminal.Command +uninstall = + let + details : String + details = + "The `uninstall` command removes packages your project:" + + example : D.Doc + example = + stack + [ reflow + "For example, if you want to remove the HTTP and JSON packages, you would say:" + , D.indent 4 <| + D.green <| + D.vcat <| + [ D.fromChars "guida uninstall elm/http" + , D.fromChars "guida uninstall elm/json" + ] + ] + + uninstallArgs : Terminal.Args + uninstallArgs = + Terminal.oneOf + [ Terminal.require0 + , Terminal.require1 Terminal.package + ] + + uninstallFlags : Terminal.Flags + uninstallFlags = + Terminal.flags + |> Terminal.more (Terminal.onOff "yes" "Reply 'yes' to all automated prompts.") + in + Terminal.Command "uninstall" Terminal.Uncommon details example uninstallArgs uninstallFlags <| + \chunks -> + Chomp.chomp Nothing + chunks + [ Chomp.chompExactly (Chomp.pure Uninstall.NoArgs) + , Chomp.chompExactly + (Chomp.pure Uninstall.Uninstall + |> Chomp.bind + (\func -> + Chomp.chompArg (List.length chunks) Terminal.package Terminal.parsePackage + |> Chomp.fmap (\arg -> func arg) + ) + ) + ] + (Chomp.pure Uninstall.Flags + |> Chomp.apply (Chomp.chompOnOffFlag "yes") + |> Chomp.bind + (\value -> + Chomp.checkForUnknownFlags uninstallFlags + |> Chomp.fmap (\_ -> value) + ) + ) + |> Tuple.second + |> Result.map (\( args, flags ) -> Uninstall.run args flags) + + + +-- PUBLISH + + +publish : Terminal.Command +publish = + let + details : String + details = + "The `publish` command publishes your package on so that anyone in the Elm community can use it." + + example : D.Doc + example = + stack + [ reflow + "Think hard if you are ready to publish NEW packages though!" + , reflow + "Part of what makes Elm great is the packages ecosystem. The fact that there is usually one option (usually very well done) makes it way easier to pick packages and become productive. So having a million packages would be a failure in Elm. We do not need twenty of everything, all coded in a single weekend." + , reflow + "So as community members gain wisdom through experience, we want them to share that through thoughtful API design and excellent documentation. It is more about sharing ideas and insights than just sharing code! The first step may be asking for advice from people you respect, or in community forums. The second step may be using it at work to see if it is as nice as you think. Maybe it ends up as an experiment on GitHub only. Point is, try to be respectful of the community and package ecosystem!" + , reflow + "Check out for guidance on how to create great packages!" + ] + in + Terminal.Command "publish" Terminal.Uncommon details example Terminal.noArgs Terminal.noFlags <| + \chunks -> + Chomp.chomp Nothing + chunks + [ Chomp.chompExactly (Chomp.pure ()) + ] + (Chomp.pure () + |> Chomp.bind + (\value -> + Chomp.checkForUnknownFlags Terminal.noFlags + |> Chomp.fmap (\_ -> value) + ) + ) + |> Tuple.second + |> Result.map (\( args, flags ) -> Publish.run args flags) + + + +-- BUMP + + +bump : Terminal.Command +bump = + let + details : String + details = + "The `bump` command figures out the next version number based on API changes:" + + example : D.Doc + example = + reflow + "Say you just published version 1.0.0, but then decided to remove a function. I will compare the published API to what you have locally, figure out that it is a MAJOR change, and bump your version number to 2.0.0. I do this with all packages, so there cannot be MAJOR changes hiding in PATCH releases in Elm!" + in + Terminal.Command "bump" Terminal.Uncommon details example Terminal.noArgs Terminal.noFlags <| + \chunks -> + Chomp.chomp Nothing + chunks + [ Chomp.chompExactly (Chomp.pure ()) + ] + (Chomp.pure () + |> Chomp.bind + (\value -> + Chomp.checkForUnknownFlags Terminal.noFlags + |> Chomp.fmap (\_ -> value) + ) + ) + |> Tuple.second + |> Result.map (\( args, flags ) -> Bump.run args flags) + + + +-- DIFF + + +diff : Terminal.Command +diff = + let + details : String + details = + "The `diff` command detects API changes:" + + example : D.Doc + example = + stack + [ reflow + "For example, to see what changed in the HTML package between versions 1.0.0 and 2.0.0, you can say:" + , D.indent 4 <| D.green <| D.fromChars "elm diff elm/html 1.0.0 2.0.0" + , reflow + "Sometimes a MAJOR change is not actually very big, so this can help you plan your upgrade timelines." + ] + + diffArgs : Terminal.Args + diffArgs = + Terminal.oneOf + [ Terminal.require0 + , Terminal.require1 Terminal.version + , Terminal.require2 Terminal.version Terminal.version + , Terminal.require3 Terminal.package Terminal.version Terminal.version + ] + in + Terminal.Command "diff" Terminal.Uncommon details example diffArgs Terminal.noFlags <| + \chunks -> + Chomp.chomp Nothing + chunks + [ Chomp.chompExactly (Chomp.pure Diff.CodeVsLatest) + , Chomp.chompExactly + (Chomp.pure Diff.CodeVsExactly + |> Chomp.bind + (\func -> + Chomp.chompArg (List.length chunks) Terminal.version Terminal.parseVersion + |> Chomp.fmap (\arg -> func arg) + ) + ) + , Chomp.chompExactly + (Chomp.pure Diff.LocalInquiry + |> Chomp.bind + (\func -> + Chomp.chompArg (List.length chunks) Terminal.version Terminal.parseVersion + |> Chomp.fmap (\arg -> func arg) + ) + |> Chomp.bind + (\func -> + Chomp.chompArg (List.length chunks) Terminal.version Terminal.parseVersion + |> Chomp.fmap (\arg -> func arg) + ) + ) + , Chomp.chompExactly + (Chomp.pure Diff.GlobalInquiry + |> Chomp.bind + (\func -> + Chomp.chompArg (List.length chunks) Terminal.package Terminal.parsePackage + |> Chomp.fmap (\arg -> func arg) + ) + |> Chomp.bind + (\func -> + Chomp.chompArg (List.length chunks) Terminal.version Terminal.parseVersion + |> Chomp.fmap (\arg -> func arg) + ) + |> Chomp.bind + (\func -> + Chomp.chompArg (List.length chunks) Terminal.version Terminal.parseVersion + |> Chomp.fmap (\arg -> func arg) + ) + ) + ] + (Chomp.pure () + |> Chomp.bind + (\value -> + Chomp.checkForUnknownFlags Terminal.noFlags + |> Chomp.fmap (\_ -> value) + ) + ) + |> Tuple.second + |> Result.map (\( args, flags ) -> Diff.run args flags) + + + +-- FORMAT + + +format : Terminal.Command +format = + let + details : String + details = + "The `format` command formats Elm code in place." + + example : D.Doc + example = + stack + [ reflow "For example:" + , D.indent 4 <| D.green (D.fromChars "guida format src/Main.elm") + , reflow "This tries to format an Elm file named src/Main.elm, formatting it in place." + ] + + formatArgs : Terminal.Args + formatArgs = + Terminal.zeroOrMore Terminal.filePath + + formatFlags : Terminal.Flags + formatFlags = + Terminal.flags + |> Terminal.more (Terminal.flag "output" output "Write output to FILE instead of overwriting the given source file.") + |> Terminal.more (Terminal.onOff "yes" "Reply 'yes' to all automated prompts.") + |> Terminal.more (Terminal.onOff "validate" "Check if files are formatted without changing them.") + |> Terminal.more (Terminal.onOff "stdin" "Read from stdin, output to stdout.") + in + Terminal.Command "format" Terminal.Uncommon details example formatArgs formatFlags <| + \chunks -> + Chomp.chomp Nothing + chunks + [ Chomp.chompMultiple (Chomp.pure identity) Terminal.filePath Terminal.parseFilePath + ] + (Chomp.pure Format.Flags + |> Chomp.apply (Chomp.chompNormalFlag "output" output Just) + |> Chomp.apply (Chomp.chompOnOffFlag "yes") + |> Chomp.apply (Chomp.chompOnOffFlag "validate") + |> Chomp.apply (Chomp.chompOnOffFlag "stdin") + |> Chomp.bind + (\value -> + Chomp.checkForUnknownFlags formatFlags + |> Chomp.fmap (\_ -> value) + ) + ) + |> Tuple.second + |> Result.map (\( args, flags ) -> Format.run args flags) + + +output : Terminal.Parser +output = + Terminal.Parser + { singular = "output" + , plural = "outputs" + , suggest = \_ -> Task.pure [] + , examples = \_ -> Task.pure [] + } + + + +-- TEST + + +test : Terminal.Command +test = + let + details : String + details = + "The `test` command runs tests." + + example : D.Doc + example = + stack + [ reflow "For example:" + , D.indent 4 <| D.green (D.fromChars "guida test") + , reflow "Run tests in the tests/ folder." + , D.indent 4 <| D.green (D.fromChars "guida test src/Main.guida") + , reflow "Run tests in files matching the glob." + ] + + testArgs : Terminal.Args + testArgs = + Terminal.zeroOrMore Terminal.filePath + + testFlags : Terminal.Flags + testFlags = + Terminal.flags + |> Terminal.more (Terminal.flag "fuzz" int "Run with a specific fuzzer seed (default: random)") + |> Terminal.more (Terminal.flag "seed" int "Define how many times each fuzz-test should run (default: 100)") + |> Terminal.more (Terminal.flag "report" Test.format "Specify which format to use for reporting test results (choices: \"json\", \"junit\", \"console\", default: \"console\")") + in + Terminal.Command "test" Terminal.Uncommon details example testArgs testFlags <| + \chunks -> + Chomp.chomp Nothing + chunks + [ Chomp.chompMultiple (Chomp.pure identity) Terminal.filePath Terminal.parseFilePath + ] + (Chomp.pure Test.Flags + |> Chomp.apply (Chomp.chompNormalFlag "seed" int parseInt) + |> Chomp.apply (Chomp.chompNormalFlag "fuzz" int parseInt) + |> Chomp.apply (Chomp.chompNormalFlag "report" Test.format Test.parseReport) + |> Chomp.bind + (\value -> + Chomp.checkForUnknownFlags testFlags + |> Chomp.fmap (\_ -> value) + ) + ) + |> Tuple.second + |> Result.map (\( args, flags ) -> Test.run args flags) + + +int : Terminal.Parser +int = + Terminal.Parser + { singular = "int" + , plural = "ints" + , suggest = \_ -> Task.pure [] + , examples = \_ -> Task.pure [] + } + + +parseInt : String -> Maybe Int +parseInt = + String.toInt + + + +-- HELPERS + + +stack : List D.Doc -> D.Doc +stack docs = + D.vcat <| List.intersperse (D.fromChars "") docs + + +reflow : String -> D.Doc +reflow string = + D.fillSep <| List.map D.fromChars <| String.words string diff --git a/src/Terminal/Make.elm b/src/Terminal/Make.elm new file mode 100644 index 0000000000..40c3050184 --- /dev/null +++ b/src/Terminal/Make.elm @@ -0,0 +1,408 @@ +module Terminal.Make exposing + ( Flags(..) + , Output(..) + , ReportType(..) + , docsFile + , output + , parseDocsFile + , parseOutput + , parseReportType + , reportType + , run + ) + +import Builder.BackgroundWriter as BW +import Builder.Build as Build +import Builder.Elm.Details as Details +import Builder.File as File +import Builder.Generate as Generate +import Builder.Reporting as Reporting +import Builder.Reporting.Exit as Exit +import Builder.Stuff as Stuff +import Compiler.AST.Optimized as Opt +import Compiler.Data.NonEmptyList as NE +import Compiler.Elm.ModuleName as ModuleName +import Compiler.Generate.Html as Html +import Maybe.Extra as Maybe +import Task exposing (Task) +import Terminal.Terminal.Internal exposing (Parser(..)) +import Utils.Bytes.Decode as BD +import Utils.Bytes.Encode as BE +import Utils.Main as Utils exposing (FilePath) +import Utils.Task.Extra as Task + + + +-- FLAGS + + +type Flags + = Flags Bool Bool Bool (Maybe Output) (Maybe ReportType) (Maybe String) + + +type Output + = JS String + | Html String + | DevNull + + +type ReportType + = Json + + + +-- RUN + + +run : List String -> Flags -> Task Never () +run paths ((Flags _ _ _ _ report _) as flags) = + getStyle report + |> Task.bind + (\style -> + Stuff.findRoot + |> Task.bind + (\maybeRoot -> + Reporting.attemptWithStyle style Exit.makeToReport <| + case maybeRoot of + Just root -> + runHelp root paths style flags + + Nothing -> + Task.pure (Err Exit.MakeNoOutline) + ) + ) + + +runHelp : String -> List String -> Reporting.Style -> Flags -> Task Never (Result Exit.Make ()) +runHelp root paths style (Flags debug optimize withSourceMaps maybeOutput _ maybeDocs) = + BW.withScope + (\scope -> + Stuff.withRootLock root <| + Task.run <| + (getMode debug optimize + |> Task.bind + (\desiredMode -> + Task.eio Exit.MakeBadDetails (Details.load style scope root) + |> Task.bind + (\details -> + case paths of + [] -> + getExposed details + |> Task.bind (\exposed -> buildExposed style root details maybeDocs exposed) + + p :: ps -> + buildPaths style root details (NE.Nonempty p ps) + |> Task.bind + (\artifacts -> + case maybeOutput of + Nothing -> + case getMains artifacts of + [] -> + Task.pure () + + [ name ] -> + toBuilder withSourceMaps Html.leadingLines root details desiredMode artifacts + |> Task.bind + (\builder -> + generate style "index.html" (Html.sandwich name builder) (NE.Nonempty name []) + ) + + name :: names -> + toBuilder withSourceMaps 0 root details desiredMode artifacts + |> Task.bind + (\builder -> + generate style "elm.js" builder (NE.Nonempty name names) + ) + + Just DevNull -> + Task.pure () + + Just (JS target) -> + case getNoMains artifacts of + [] -> + toBuilder withSourceMaps 0 root details desiredMode artifacts + |> Task.bind + (\builder -> + generate style target builder (Build.getRootNames artifacts) + ) + + name :: names -> + Task.throw (Exit.MakeNonMainFilesIntoJavaScript name names) + + Just (Html target) -> + hasOneMain artifacts + |> Task.bind + (\name -> + toBuilder withSourceMaps Html.leadingLines root details desiredMode artifacts + |> Task.bind + (\builder -> + generate style target (Html.sandwich name builder) (NE.Nonempty name []) + ) + ) + ) + ) + ) + ) + ) + + + +-- GET INFORMATION + + +getStyle : Maybe ReportType -> Task Never Reporting.Style +getStyle report = + case report of + Nothing -> + Reporting.terminal + + Just Json -> + Task.pure Reporting.json + + +getMode : Bool -> Bool -> Task Exit.Make DesiredMode +getMode debug optimize = + case ( debug, optimize ) of + ( True, True ) -> + Task.throw Exit.MakeCannotOptimizeAndDebug + + ( True, False ) -> + Task.pure Debug + + ( False, False ) -> + Task.pure Dev + + ( False, True ) -> + Task.pure Prod + + +getExposed : Details.Details -> Task Exit.Make (NE.Nonempty ModuleName.Raw) +getExposed (Details.Details _ validOutline _ _ _ _) = + case validOutline of + Details.ValidApp _ -> + Task.throw Exit.MakeAppNeedsFileNames + + Details.ValidPkg _ exposed _ -> + case exposed of + [] -> + Task.throw Exit.MakePkgNeedsExposing + + m :: ms -> + Task.pure (NE.Nonempty m ms) + + + +-- BUILD PROJECTS + + +buildExposed : Reporting.Style -> FilePath -> Details.Details -> Maybe FilePath -> NE.Nonempty ModuleName.Raw -> Task Exit.Make () +buildExposed style root details maybeDocs exposed = + let + docsGoal : Build.DocsGoal () + docsGoal = + Maybe.unwrap Build.ignoreDocs Build.writeDocs maybeDocs + in + Task.eio Exit.MakeCannotBuild <| + Build.fromExposed BD.unit + BE.unit + style + root + details + docsGoal + exposed + + +buildPaths : Reporting.Style -> FilePath -> Details.Details -> NE.Nonempty FilePath -> Task Exit.Make Build.Artifacts +buildPaths style root details paths = + Task.eio Exit.MakeCannotBuild <| + Build.fromPaths style root details paths + + + +-- GET MAINS + + +getMains : Build.Artifacts -> List ModuleName.Raw +getMains (Build.Artifacts _ _ roots modules) = + List.filterMap (getMain modules) (NE.toList roots) + + +getMain : List Build.Module -> Build.Root -> Maybe ModuleName.Raw +getMain modules root = + case root of + Build.Inside name -> + if List.any (isMain name) modules then + Just name + + else + Nothing + + Build.Outside name _ (Opt.LocalGraph maybeMain _ _) -> + maybeMain + |> Maybe.map (\_ -> name) + + +isMain : ModuleName.Raw -> Build.Module -> Bool +isMain targetName modul = + case modul of + Build.Fresh name _ (Opt.LocalGraph maybeMain _ _) -> + Maybe.isJust maybeMain && name == targetName + + Build.Cached name mainIsDefined _ -> + mainIsDefined && name == targetName + + + +-- HAS ONE MAIN + + +hasOneMain : Build.Artifacts -> Task Exit.Make ModuleName.Raw +hasOneMain (Build.Artifacts _ _ roots modules) = + case roots of + NE.Nonempty root [] -> + Task.mio Exit.MakeNoMain (Task.pure <| getMain modules root) + + NE.Nonempty _ (_ :: _) -> + Task.throw Exit.MakeMultipleFilesIntoHtml + + + +-- GET MAINLESS + + +getNoMains : Build.Artifacts -> List ModuleName.Raw +getNoMains (Build.Artifacts _ _ roots modules) = + List.filterMap (getNoMain modules) (NE.toList roots) + + +getNoMain : List Build.Module -> Build.Root -> Maybe ModuleName.Raw +getNoMain modules root = + case root of + Build.Inside name -> + if List.any (isMain name) modules then + Nothing + + else + Just name + + Build.Outside name _ (Opt.LocalGraph maybeMain _ _) -> + case maybeMain of + Just _ -> + Nothing + + Nothing -> + Just name + + + +-- GENERATE + + +generate : Reporting.Style -> FilePath -> String -> NE.Nonempty ModuleName.Raw -> Task Exit.Make () +generate style target builder names = + Task.io + (Utils.dirCreateDirectoryIfMissing True (Utils.fpTakeDirectory target) + |> Task.bind (\_ -> File.writeUtf8 target builder) + |> Task.bind (\_ -> Reporting.reportGenerate style names target) + ) + + + +-- TO BUILDER + + +type DesiredMode + = Debug + | Dev + | Prod + + +toBuilder : Bool -> Int -> FilePath -> Details.Details -> DesiredMode -> Build.Artifacts -> Task Exit.Make String +toBuilder withSourceMaps leadingLines root details desiredMode artifacts = + Task.mapError Exit.MakeBadGenerate <| + case desiredMode of + Debug -> + Generate.debug withSourceMaps leadingLines root details artifacts + + Dev -> + Generate.dev withSourceMaps leadingLines root details artifacts + + Prod -> + Generate.prod withSourceMaps leadingLines root details artifacts + + + +-- PARSERS + + +reportType : Parser +reportType = + Parser + { singular = "report type" + , plural = "report types" + , suggest = \_ -> Task.pure [ "json" ] + , examples = \_ -> Task.pure [ "json" ] + } + + +parseReportType : String -> Maybe ReportType +parseReportType string = + if string == "json" then + Just Json + + else + Nothing + + +output : Parser +output = + Parser + { singular = "output file" + , plural = "output files" + , suggest = \_ -> Task.pure [] + , examples = \_ -> Task.pure [ "elm.js", "index.html", "/dev/null" ] + } + + +parseOutput : String -> Maybe Output +parseOutput name = + if isDevNull name then + Just DevNull + + else if hasExt ".html" name then + Just (Html name) + + else if hasExt ".js" name then + Just (JS name) + + else + Nothing + + +docsFile : Parser +docsFile = + Parser + { singular = "json file" + , plural = "json files" + , suggest = \_ -> Task.pure [] + , examples = \_ -> Task.pure [ "docs.json", "documentation.json" ] + } + + +parseDocsFile : String -> Maybe String +parseDocsFile name = + if hasExt ".json" name then + Just name + + else + Nothing + + +hasExt : String -> String -> Bool +hasExt ext path = + Utils.fpTakeExtension path == ext && String.length path > String.length ext + + +isDevNull : String -> Bool +isDevNull name = + name == "/dev/null" || name == "NUL" || name == "<|null" diff --git a/src/Terminal/Publish.elm b/src/Terminal/Publish.elm new file mode 100644 index 0000000000..46ab6c3a75 --- /dev/null +++ b/src/Terminal/Publish.elm @@ -0,0 +1,707 @@ +module Terminal.Publish exposing (run) + +import Builder.BackgroundWriter as BW +import Builder.Build as Build +import Builder.Deps.Bump as Bump +import Builder.Deps.Diff as Diff +import Builder.Deps.Registry as Registry +import Builder.Deps.Website as Website +import Builder.Elm.Details as Details +import Builder.Elm.Outline as Outline +import Builder.File as File +import Builder.Http as Http +import Builder.Reporting as Reporting +import Builder.Reporting.Exit as Exit +import Builder.Reporting.Exit.Help as Help +import Builder.Stuff as Stuff +import Compiler.Data.NonEmptyList as NE +import Compiler.Elm.Docs as Docs +import Compiler.Elm.Magnitude as M +import Compiler.Elm.Package as Pkg +import Compiler.Elm.Version as V +import Compiler.Json.Decode as D +import Compiler.Json.String as Json +import Compiler.Reporting.Doc as D +import List.Extra as List +import System.Exit as Exit +import System.IO as IO +import System.Process as Process +import Task exposing (Task) +import Utils.Main as Utils exposing (FilePath) +import Utils.Task.Extra as Task + + + +-- RUN + + +{-| TODO mandate no "exposing (..)" in packages to make +optimization to skip builds in Elm.Details always valid +-} +run : () -> () -> Task Never () +run () () = + Reporting.attempt Exit.publishToReport <| + Task.run (Task.bind publish getEnv) + + + +-- ENV + + +type Env + = Env FilePath Stuff.PackageCache Http.Manager Registry.Registry Outline.Outline + + +getEnv : Task Exit.Publish Env +getEnv = + Task.mio Exit.PublishNoOutline Stuff.findRoot + |> Task.bind + (\root -> + Task.io Stuff.getPackageCache + |> Task.bind + (\cache -> + Task.io Http.getManager + |> Task.bind + (\manager -> + Task.eio Exit.PublishMustHaveLatestRegistry (Registry.latest manager cache) + |> Task.bind + (\registry -> + Task.eio Exit.PublishBadOutline (Outline.read root) + |> Task.fmap + (\outline -> + Env root cache manager registry outline + ) + ) + ) + ) + ) + + + +-- PUBLISH + + +publish : Env -> Task Exit.Publish () +publish ((Env root _ manager registry outline) as env) = + case outline of + Outline.App _ -> + Task.throw Exit.PublishApplication + + Outline.Pkg (Outline.PkgOutline pkg summary _ vsn exposed _ _ _) -> + let + maybeKnownVersions : Maybe Registry.KnownVersions + maybeKnownVersions = + Registry.getVersions pkg registry + in + reportPublishStart pkg vsn maybeKnownVersions + |> Task.bind + (\_ -> + if noExposed exposed then + Task.throw Exit.PublishNoExposed + + else + Task.pure () + ) + |> Task.bind + (\_ -> + if badSummary summary then + Task.throw Exit.PublishNoSummary + + else + Task.pure () + ) + |> Task.bind (\_ -> verifyReadme root) + |> Task.bind (\_ -> verifyLicense root) + |> Task.bind (\_ -> verifyBuild root) + |> Task.bind + (\docs -> + verifyVersion env pkg vsn docs maybeKnownVersions + |> Task.bind (\_ -> getGit) + |> Task.bind + (\git -> + verifyTag git manager pkg vsn + |> Task.bind + (\commitHash -> + verifyNoChanges git commitHash vsn + |> Task.bind + (\_ -> + verifyZip env pkg vsn + |> Task.bind + (\zipHash -> + Task.io (IO.putStrLn "") + |> Task.bind (\_ -> register manager pkg vsn docs commitHash zipHash) + |> Task.bind (\_ -> Task.io (IO.putStrLn "Success!")) + ) + ) + ) + ) + ) + + + +-- VERIFY SUMMARY + + +badSummary : String -> Bool +badSummary summary = + Json.isEmpty summary || Outline.defaultSummary == summary + + +noExposed : Outline.Exposed -> Bool +noExposed exposed = + case exposed of + Outline.ExposedList modules -> + List.isEmpty modules + + Outline.ExposedDict chunks -> + List.all (List.isEmpty << Tuple.second) chunks + + + +-- VERIFY README + + +verifyReadme : String -> Task Exit.Publish () +verifyReadme root = + let + readmePath : String + readmePath = + root ++ "/README.md" + in + reportReadmeCheck <| + (File.exists readmePath + |> Task.bind + (\exists -> + if exists then + IO.withFile readmePath IO.ReadMode IO.hFileSize + |> Task.fmap + (\size -> + if size < 300 then + Err Exit.PublishShortReadme + + else + Ok () + ) + + else + Task.pure (Err Exit.PublishNoReadme) + ) + ) + + + +-- VERIFY LICENSE + + +verifyLicense : String -> Task Exit.Publish () +verifyLicense root = + let + licensePath : String + licensePath = + root ++ "/LICENSE" + in + reportLicenseCheck <| + (File.exists licensePath + |> Task.fmap + (\exists -> + if exists then + Ok () + + else + Err Exit.PublishNoLicense + ) + ) + + + +-- VERIFY BUILD + + +verifyBuild : String -> Task Exit.Publish Docs.Documentation +verifyBuild root = + reportBuildCheck <| + BW.withScope <| + \scope -> + Task.run + (Task.eio Exit.PublishBadDetails + (Details.load Reporting.silent scope root) + |> Task.bind + (\((Details.Details _ outline _ _ _ _) as details) -> + (case outline of + Details.ValidApp _ -> + Task.throw Exit.PublishApplication + + Details.ValidPkg _ [] _ -> + Task.throw Exit.PublishNoExposed + + Details.ValidPkg _ (e :: es) _ -> + Task.pure (NE.Nonempty e es) + ) + |> Task.bind + (\exposed -> + Task.eio Exit.PublishBuildProblem <| + Build.fromExposed Docs.bytesDecoder Docs.bytesEncoder Reporting.silent root details Build.keepDocs exposed + ) + ) + ) + + + +-- GET GIT + + +type Git + = Git (List String -> Task Never Exit.ExitCode) + + +getGit : Task Exit.Publish Git +getGit = + Task.io (Utils.dirFindExecutable "git") + |> Task.bind + (\maybeGit -> + case maybeGit of + Nothing -> + Task.throw Exit.PublishNoGit + + Just git -> + Task.pure <| + Git + (\args -> + let + process : { cmdspec : Process.CmdSpec, std_in : Process.StdStream, std_out : Process.StdStream, std_err : Process.StdStream } + process = + Process.proc git args + |> (\cp -> + { cp + | std_in = Process.CreatePipe + , std_out = Process.CreatePipe + , std_err = Process.CreatePipe + } + ) + in + Process.withCreateProcess process + (\_ _ _ handle -> + Process.waitForProcess handle + ) + ) + ) + + + +-- VERIFY GITHUB TAG + + +verifyTag : Git -> Http.Manager -> Pkg.Name -> V.Version -> Task Exit.Publish String +verifyTag (Git run_) manager pkg vsn = + reportTagCheck vsn + -- https://stackoverflow.com/questions/1064499/how-to-list-all-git-tags + (run_ [ "show", "--name-only", V.toChars vsn, "--" ] + |> Task.bind + (\exitCode -> + case exitCode of + Exit.ExitFailure _ -> + Task.pure (Err (Exit.PublishMissingTag vsn)) + + Exit.ExitSuccess -> + let + url : String + url = + toTagUrl pkg vsn + in + Http.get manager url [ Http.accept "application/json" ] (Exit.PublishCannotGetTag vsn) <| + \body -> + case D.fromByteString commitHashDecoder body of + Ok hash -> + Task.pure <| Ok hash + + Err _ -> + Task.pure <| Err (Exit.PublishCannotGetTagData vsn url body) + ) + ) + + +toTagUrl : Pkg.Name -> V.Version -> String +toTagUrl pkg vsn = + "https://api.github.com/repos/" ++ Pkg.toUrl pkg ++ "/git/refs/tags/" ++ V.toChars vsn + + +commitHashDecoder : D.Decoder e String +commitHashDecoder = + D.field "object" (D.field "sha" D.string) + + + +-- VERIFY NO LOCAL CHANGES SINCE TAG + + +verifyNoChanges : Git -> String -> V.Version -> Task Exit.Publish () +verifyNoChanges (Git run_) commitHash vsn = + reportLocalChangesCheck <| + -- https://stackoverflow.com/questions/3878624/how-do-i-programmatically-determine-if-there-are-uncommited-changes + (run_ [ "diff-index", "--quiet", commitHash, "--" ] + |> Task.fmap + (\exitCode -> + case exitCode of + Exit.ExitSuccess -> + Ok () + + Exit.ExitFailure _ -> + Err (Exit.PublishLocalChanges vsn) + ) + ) + + + +-- VERIFY THAT ZIP BUILDS / COMPUTE HASH + + +verifyZip : Env -> Pkg.Name -> V.Version -> Task Exit.Publish Http.Sha +verifyZip (Env root _ manager _ _) pkg vsn = + withPrepublishDir root <| + \prepublishDir -> + let + url : String + url = + toZipUrl pkg vsn + in + reportDownloadCheck + (Http.getArchive manager + url + Exit.PublishCannotGetZip + (Exit.PublishCannotDecodeZip url) + (Task.pure << Ok) + ) + |> Task.bind + (\( sha, archive ) -> + Task.io (File.writePackage prepublishDir archive) + |> Task.bind + (\_ -> + reportZipBuildCheck <| + Utils.dirWithCurrentDirectory prepublishDir <| + verifyZipBuild prepublishDir + ) + |> Task.fmap (\_ -> sha) + ) + + +toZipUrl : Pkg.Name -> V.Version -> String +toZipUrl pkg vsn = + "https://github.com/" ++ Pkg.toUrl pkg ++ "/zipball/" ++ V.toChars vsn ++ "/" + + +withPrepublishDir : String -> (String -> Task x a) -> Task x a +withPrepublishDir root callback = + let + dir : String + dir = + Stuff.prepublishDir root + in + Task.eio identity <| + Utils.bracket_ + (Utils.dirCreateDirectoryIfMissing True dir) + (Utils.dirRemoveDirectoryRecursive dir) + (Task.run (callback dir)) + + +verifyZipBuild : FilePath -> Task Never (Result Exit.Publish ()) +verifyZipBuild root = + BW.withScope + (\scope -> + Task.run + (Task.eio Exit.PublishZipBadDetails + (Details.load Reporting.silent scope root) + |> Task.bind + (\((Details.Details _ outline _ _ _ _) as details) -> + (case outline of + Details.ValidApp _ -> + Task.throw Exit.PublishZipApplication + + Details.ValidPkg _ [] _ -> + Task.throw Exit.PublishZipNoExposed + + Details.ValidPkg _ (e :: es) _ -> + Task.pure (NE.Nonempty e es) + ) + |> Task.bind + (\exposed -> + Task.eio Exit.PublishZipBuildProblem + (Build.fromExposed Docs.bytesDecoder Docs.bytesEncoder Reporting.silent root details Build.keepDocs exposed) + |> Task.fmap (\_ -> ()) + ) + ) + ) + ) + + + +-- VERIFY VERSION + + +type GoodVersion + = GoodStart + | GoodBump V.Version M.Magnitude + + +verifyVersion : Env -> Pkg.Name -> V.Version -> Docs.Documentation -> Maybe Registry.KnownVersions -> Task Exit.Publish () +verifyVersion env pkg vsn newDocs publishedVersions = + reportSemverCheck vsn <| + case publishedVersions of + Nothing -> + if vsn == V.one then + Task.pure <| Ok GoodStart + + else + Task.pure <| Err <| Exit.PublishNotInitialVersion vsn + + Just ((Registry.KnownVersions latest previous) as knownVersions) -> + if vsn == latest || List.member vsn previous then + Task.pure <| Err <| Exit.PublishAlreadyPublished vsn + + else + verifyBump env pkg vsn newDocs knownVersions + + +verifyBump : Env -> Pkg.Name -> V.Version -> Docs.Documentation -> Registry.KnownVersions -> Task Never (Result Exit.Publish GoodVersion) +verifyBump (Env _ cache manager _ _) pkg vsn newDocs ((Registry.KnownVersions latest _) as knownVersions) = + case List.find (\( _, new, _ ) -> vsn == new) (Bump.getPossibilities knownVersions) of + Nothing -> + Task.pure <| + Err <| + Exit.PublishInvalidBump vsn latest + + Just ( old, new, magnitude ) -> + Diff.getDocs cache manager pkg old + |> Task.fmap + (\result -> + case result of + Err dp -> + Err <| Exit.PublishCannotGetDocs old new dp + + Ok oldDocs -> + let + changes : Diff.PackageChanges + changes = + Diff.diff oldDocs newDocs + + realNew : V.Version + realNew = + Diff.bump changes old + in + if new == realNew then + Ok <| GoodBump old magnitude + + else + Err <| + Exit.PublishBadBump old new magnitude realNew (Diff.toMagnitude changes) + ) + + + +-- REGISTER PACKAGES + + +register : Http.Manager -> Pkg.Name -> V.Version -> Docs.Documentation -> String -> Http.Sha -> Task Exit.Publish () +register manager pkg vsn docs commitHash sha = + Website.route "/register" + [ ( "name", Pkg.toChars pkg ) + , ( "version", V.toChars vsn ) + , ( "commit-hash", commitHash ) + ] + |> Task.bind + (\url -> + Http.upload manager + url + [ Http.filePart "elm.json" "elm.json" + , Http.jsonPart "docs.json" "docs.json" (Docs.jsonEncoder docs) + , Http.filePart "README.md" "README.md" + , Http.stringPart "github-hash" (Http.shaToChars sha) + ] + ) + |> Task.eio Exit.PublishCannotRegister + + + +-- REPORTING + + +reportPublishStart : Pkg.Name -> V.Version -> Maybe Registry.KnownVersions -> Task x () +reportPublishStart pkg vsn maybeKnownVersions = + Task.io <| + case maybeKnownVersions of + Nothing -> + IO.putStrLn <| Exit.newPackageOverview ++ "\nI will now verify that everything is in order...\n" + + Just _ -> + IO.putStrLn <| "Verifying " ++ Pkg.toChars pkg ++ " " ++ V.toChars vsn ++ " ...\n" + + + +-- REPORTING PHASES + + +reportReadmeCheck : Task Never (Result x a) -> Task x a +reportReadmeCheck = + reportCheck + "Looking for README.md" + "Found README.md" + "Problem with your README.md" + + +reportLicenseCheck : Task Never (Result x a) -> Task x a +reportLicenseCheck = + reportCheck + "Looking for LICENSE" + "Found LICENSE" + "Problem with your LICENSE" + + +reportBuildCheck : Task Never (Result x a) -> Task x a +reportBuildCheck = + reportCheck + "Verifying documentation..." + "Verified documentation" + "Problem with documentation" + + +reportSemverCheck : V.Version -> Task Never (Result x GoodVersion) -> Task x () +reportSemverCheck version work = + let + vsn : String + vsn = + V.toChars version + + waiting : String + waiting = + "Checking semantic versioning rules. Is " ++ vsn ++ " correct?" + + failure : String + failure = + "Version " ++ vsn ++ " is not correct!" + + success : GoodVersion -> String + success result = + case result of + GoodStart -> + "All packages start at version " ++ V.toChars V.one + + GoodBump oldVersion magnitude -> + "Version number " + ++ vsn + ++ " verified (" + ++ M.toChars magnitude + ++ " change, " + ++ V.toChars oldVersion + ++ " => " + ++ vsn + ++ ")" + in + Task.void <| reportCustomCheck waiting success failure work + + +reportTagCheck : V.Version -> Task Never (Result x a) -> Task x a +reportTagCheck vsn = + reportCheck + ("Is version " ++ V.toChars vsn ++ " tagged on GitHub?") + ("Version " ++ V.toChars vsn ++ " is tagged on GitHub") + ("Version " ++ V.toChars vsn ++ " is not tagged on GitHub!") + + +reportDownloadCheck : Task Never (Result x a) -> Task x a +reportDownloadCheck = + reportCheck + "Downloading code from GitHub..." + "Code downloaded successfully from GitHub" + "Could not download code from GitHub!" + + +reportLocalChangesCheck : Task Never (Result x a) -> Task x a +reportLocalChangesCheck = + reportCheck + "Checking for uncommitted changes..." + "No uncommitted changes in local code" + "Your local code is different than the code tagged on GitHub" + + +reportZipBuildCheck : Task Never (Result x a) -> Task x a +reportZipBuildCheck = + reportCheck + "Verifying downloaded code..." + "Downloaded code compiles successfully" + "Cannot compile downloaded code!" + + +reportCheck : String -> String -> String -> Task Never (Result x a) -> Task x a +reportCheck waiting success failure work = + reportCustomCheck waiting (\_ -> success) failure work + + +reportCustomCheck : String -> (a -> String) -> String -> Task Never (Result x a) -> Task x a +reportCustomCheck waiting success failure work = + let + putFlush : D.Doc -> Task Never () + putFlush doc = + Help.toStdout doc |> Task.bind (\_ -> IO.hFlush IO.stdout) + + padded : String -> String + padded message = + message ++ String.repeat (String.length waiting - String.length message) " " + in + Task.eio identity + (putFlush (D.append (D.fromChars " ") waitingMark |> D.plus (D.fromChars waiting)) + |> Task.bind + (\_ -> + work + |> Task.bind + (\result -> + putFlush + (case result of + Ok a -> + D.append (D.fromChars "\u{000D} ") goodMark |> D.plus (D.fromChars (padded (success a) ++ "\n")) + + Err _ -> + D.append (D.fromChars "\u{000D} ") badMark |> D.plus (D.fromChars (padded failure ++ "\n\n")) + ) + |> Task.fmap (\_ -> result) + ) + ) + ) + + + +-- MARKS + + +goodMark : D.Doc +goodMark = + D.green <| + if isWindows then + D.fromChars "+" + + else + D.fromChars "●" + + +badMark : D.Doc +badMark = + D.red <| + if isWindows then + D.fromChars "X" + + else + D.fromChars "✗" + + +waitingMark : D.Doc +waitingMark = + D.dullyellow <| + if isWindows then + D.fromChars "-" + + else + D.fromChars "→" + + +isWindows : Bool +isWindows = + -- Info.os == "mingw32" + False diff --git a/src/Terminal/Repl.elm b/src/Terminal/Repl.elm new file mode 100644 index 0000000000..cf3f8db07b --- /dev/null +++ b/src/Terminal/Repl.elm @@ -0,0 +1,873 @@ +module Terminal.Repl exposing + ( CategorizedInput(..) + , Flags(..) + , Input(..) + , Lines(..) + , Output(..) + , Prefill(..) + , run + ) + +import Builder.BackgroundWriter as BW +import Builder.Build as Build +import Builder.Elm.Details as Details +import Builder.Elm.Outline as Outline +import Builder.Generate as Generate +import Builder.Reporting as Reporting +import Builder.Reporting.Exit as Exit +import Builder.Stuff as Stuff +import Compiler.AST.Source as Src +import Compiler.Data.Name as N +import Compiler.Elm.Constraint as C +import Compiler.Elm.Licenses as Licenses +import Compiler.Elm.ModuleName as ModuleName +import Compiler.Elm.Package as Pkg +import Compiler.Elm.Version as V +import Compiler.Parse.Declaration as PD +import Compiler.Parse.Expression as PE +import Compiler.Parse.Module as PM +import Compiler.Parse.Primitives as P exposing (Col, Row) +import Compiler.Parse.Space as PS +import Compiler.Parse.SyntaxVersion as SV +import Compiler.Parse.Type as PT +import Compiler.Parse.Variable as PV +import Compiler.Reporting.Annotation as A +import Compiler.Reporting.Doc as D +import Compiler.Reporting.Error.Syntax as ES +import Compiler.Reporting.Render.Code as Code +import Compiler.Reporting.Report as Report +import Control.Monad.State.Strict as State +import Data.Map as Map exposing (Dict) +import Dict +import List.Extra as List +import Maybe.Extra as Maybe +import Prelude +import System.Exit as Exit +import System.IO as IO +import System.Process as Process +import Task exposing (Task) +import Utils.Crash exposing (crash) +import Utils.Main as Utils exposing (FilePath) +import Utils.Task.Extra as Task + + + +-- RUN + + +type Flags + = Flags (Maybe FilePath) Bool + + +run : () -> Flags -> Task Never () +run () flags = + printWelcomeMessage + |> Task.bind (\_ -> initSettings) + |> Task.bind + (\settings -> + initEnv flags + |> Task.bind + (\env -> + let + looper : M Exit.ExitCode + looper = + Utils.replRunInputT settings (Utils.replWithInterrupt (loop env IO.initialReplState)) + in + State.evalStateT looper IO.initialReplState + |> Task.bind (\exitCode -> Exit.exitWith exitCode) + ) + ) + + + +-- WELCOME + + +printWelcomeMessage : Task Never () +printWelcomeMessage = + let + vsn : String + vsn = + V.toChars V.compiler + + title : D.Doc + title = + D.fromChars "Guida" + |> D.plus (D.fromChars vsn) + + dashes : String + dashes = + String.repeat (70 - String.length vsn) "-" + in + D.toAnsi IO.stdout <| + D.vcat + [ D.black (D.fromChars "----") + |> D.plus (D.dullcyan title) + |> D.plus (D.black (D.fromChars dashes)) + , D.black (D.fromChars "Say :help for help and :exit to exit! More at ") + |> D.a (D.fromChars (D.makeLink "repl")) + , D.black (D.fromChars "--------------------------------------------------------------------------------") + , D.fromChars "" + ] + + + +-- ENV + + +type Env + = Env FilePath FilePath Bool + + +initEnv : Flags -> Task Never Env +initEnv (Flags maybeAlternateInterpreter noColors) = + getRoot + |> Task.bind + (\root -> + getInterpreter maybeAlternateInterpreter + |> Task.fmap + (\interpreter -> + Env root interpreter (not noColors) + ) + ) + + + +-- LOOP + + +type Outcome + = Loop IO.ReplState + | End Exit.ExitCode + + +type alias M a = + State.StateT IO.ReplState a + + +loop : Env -> IO.ReplState -> Utils.ReplInputT Exit.ExitCode +loop env state = + read + |> Task.bind + (\input -> + Utils.liftIOInputT (eval env state input) + |> Task.bind + (\outcome -> + case outcome of + Loop loopState -> + Utils.liftInputT (State.put loopState) + |> Task.bind (\_ -> loop env loopState) + + End exitCode -> + Task.pure exitCode + ) + ) + + + +-- READ + + +type Input + = Import ModuleName.Raw String + | Type N.Name String + | Port + | Decl N.Name String + | Expr String + -- + | Reset + | Exit + | Skip + | Help (Maybe String) + + +read : Utils.ReplInputT Input +read = + Utils.replGetInputLine "> " + |> Task.bind + (\maybeLine -> + case maybeLine of + Nothing -> + Task.pure Exit + + Just chars -> + let + lines : Lines + lines = + Lines (stripLegacyBackslash chars) [] + in + case categorize lines of + Done input -> + Task.pure input + + Continue p -> + readMore lines p + ) + + +readMore : Lines -> Prefill -> Utils.ReplInputT Input +readMore previousLines prefill = + Utils.replGetInputLineWithInitial "| " ( renderPrefill prefill, "" ) + |> Task.bind + (\input -> + case input of + Nothing -> + Task.pure Skip + + Just chars -> + let + lines : Lines + lines = + addLine (stripLegacyBackslash chars) previousLines + in + case categorize lines of + Done doneInput -> + Task.pure doneInput + + Continue p -> + readMore lines p + ) + + + +-- For compatibility with 0.19.0 such that readers of "Programming Elm" by @jfairbank +-- can get through the REPL section successfully. +-- +-- TODO: remove stripLegacyBackslash in next MAJOR release +-- + + +stripLegacyBackslash : String -> String +stripLegacyBackslash chars = + case String.toList chars of + [] -> + "" + + (_ :: _) as charsList -> + if Prelude.last charsList == '\\' then + String.fromList (Prelude.init charsList) + + else + chars + + +type Prefill + = Indent + | DefStart N.Name + + +renderPrefill : Prefill -> String +renderPrefill lineStart = + case lineStart of + Indent -> + " " + + DefStart name -> + name ++ " " + + + +-- LINES + + +type Lines + = Lines String (List String) + + +addLine : String -> Lines -> Lines +addLine line (Lines x xs) = + Lines line (x :: xs) + + +isBlank : Lines -> Bool +isBlank (Lines prev rev) = + List.isEmpty rev && String.all ((==) ' ') prev + + +isSingleLine : Lines -> Bool +isSingleLine (Lines _ rev) = + List.isEmpty rev + + +endsWithBlankLine : Lines -> Bool +endsWithBlankLine (Lines prev _) = + String.all ((==) ' ') prev + + +linesToByteString : Lines -> String +linesToByteString (Lines prev rev) = + Utils.unlines (List.reverse (prev :: rev)) + + +getFirstLine : Lines -> String +getFirstLine (Lines x xs) = + case xs of + [] -> + x + + y :: ys -> + getFirstLine (Lines y ys) + + + +-- CATEGORIZE INPUT + + +type CategorizedInput + = Done Input + | Continue Prefill + + +categorize : Lines -> CategorizedInput +categorize lines = + if isBlank lines then + Done Skip + + else if startsWithColon lines then + Done (toCommand lines) + + else if startsWithKeyword "import" lines then + attemptImport lines + + else + attemptDeclOrExpr lines + + +attemptImport : Lines -> CategorizedInput +attemptImport lines = + let + src : String + src = + linesToByteString lines + + parser : P.Parser () (Src.C1 Src.Import) + parser = + P.specialize (\_ _ _ -> ()) PM.chompImport + in + case P.fromByteString parser (\_ _ -> ()) src of + Ok ( _, Src.Import ( _, A.At _ name ) _ _ ) -> + Done (Import name src) + + Err () -> + ifFail lines (Import "ERR" src) + + +ifFail : Lines -> Input -> CategorizedInput +ifFail lines input = + if endsWithBlankLine lines then + Done input + + else + Continue Indent + + +ifDone : Lines -> Input -> CategorizedInput +ifDone lines input = + if isSingleLine lines || endsWithBlankLine lines then + Done input + + else + Continue Indent + + +attemptDeclOrExpr : Lines -> CategorizedInput +attemptDeclOrExpr lines = + let + src : String + src = + linesToByteString lines + + declParser : P.Parser ( Row, Col ) ( PD.Decl, A.Position ) + declParser = + P.specialize (toDeclPosition src) (P.fmap (Tuple.mapFirst Src.c2Value) (PD.declaration SV.Guida)) + in + case P.fromByteString declParser Tuple.pair src of + Ok ( decl, _ ) -> + case decl of + PD.Value _ (A.At _ (Src.Value _ ( _, A.At _ name ) _ _ _)) -> + ifDone lines (Decl name src) + + PD.Union _ (A.At _ (Src.Union ( _, A.At _ name ) _ _)) -> + ifDone lines (Type name src) + + PD.Alias _ (A.At _ (Src.Alias _ ( _, A.At _ name ) _ _)) -> + ifDone lines (Type name src) + + PD.Port _ _ -> + Done Port + + Err declPosition -> + if startsWithKeyword "type" lines then + ifFail lines (Type "ERR" src) + + else if startsWithKeyword "port" lines then + Done Port + + else + let + exprParser : P.Parser ( Row, Col ) ( Src.C1 Src.Expr, A.Position ) + exprParser = + P.specialize (toExprPosition src) (PE.expression SV.Guida) + in + case P.fromByteString exprParser Tuple.pair src of + Ok _ -> + ifDone lines (Expr src) + + Err exprPosition -> + if exprPosition >= declPosition then + ifFail lines (Expr src) + + else + case P.fromByteString annotation (\_ _ -> ()) src of + Ok name -> + Continue (DefStart name) + + Err () -> + ifFail lines (Decl "ERR" src) + + +startsWithColon : Lines -> Bool +startsWithColon lines = + case List.dropWhile ((==) ' ') (String.toList (getFirstLine lines)) of + [] -> + False + + c :: _ -> + c == ':' + + +toCommand : Lines -> Input +toCommand lines = + case String.fromList <| List.drop 1 <| List.dropWhile ((==) ' ') (String.toList (getFirstLine lines)) of + "reset" -> + Reset + + "exit" -> + Exit + + "quit" -> + Exit + + "help" -> + Help Nothing + + rest -> + Help (Just (String.fromList (List.takeWhile ((/=) ' ') (String.toList rest)))) + + +startsWithKeyword : String -> Lines -> Bool +startsWithKeyword keyword lines = + let + line : String + line = + getFirstLine lines + in + String.startsWith keyword line + && (case List.drop (String.length keyword) (String.toList line) of + [] -> + True + + c :: _ -> + not (Char.isAlphaNum c) + ) + + +toExprPosition : String -> ES.Expr -> Row -> Col -> ( Row, Col ) +toExprPosition src expr row col = + let + decl : ES.Decl + decl = + ES.DeclDef N.replValueToPrint (ES.DeclDefBody expr row col) row col + in + toDeclPosition src decl row col + + +toDeclPosition : String -> ES.Decl -> Row -> Col -> ( Row, Col ) +toDeclPosition src decl r c = + let + err : ES.Error + err = + ES.ParseError (ES.Declarations decl r c) + + report : Report.Report + report = + ES.toReport SV.Guida (Code.toSource src) err + + (Report.Report _ (A.Region (A.Position row col) _) _ _) = + report + in + ( row, col ) + + +annotation : P.Parser () N.Name +annotation = + let + err : Row -> Col -> () + err _ _ = + () + + err_ : x -> Row -> Col -> () + err_ _ _ _ = + () + in + PV.lower err + |> P.bind + (\name -> + PS.chompAndCheckIndent err_ err + |> P.bind (\_ -> P.word1 ':' err) + |> P.bind (\_ -> PS.chompAndCheckIndent err_ err) + |> P.bind (\_ -> P.specialize err_ (PT.expression [])) + |> P.bind (\_ -> PS.checkFreshLine err) + |> P.fmap (\_ -> name) + ) + + + +-- EVAL + + +eval : Env -> IO.ReplState -> Input -> Task Never Outcome +eval env ((IO.ReplState imports types decls) as state) input = + case input of + Skip -> + Task.pure (Loop state) + + Exit -> + Task.pure (End Exit.ExitSuccess) + + Reset -> + IO.putStrLn "" + |> Task.fmap (\_ -> Loop IO.initialReplState) + + Help maybeUnknownCommand -> + IO.putStrLn (toHelpMessage maybeUnknownCommand) + |> Task.fmap (\_ -> Loop state) + + Import name src -> + let + newState : IO.ReplState + newState = + IO.ReplState (Dict.insert name src imports) types decls + in + Task.fmap Loop (attemptEval env state newState OutputNothing) + + Type name src -> + let + newState : IO.ReplState + newState = + IO.ReplState imports (Dict.insert name src types) decls + in + Task.fmap Loop (attemptEval env state newState OutputNothing) + + Port -> + IO.putStrLn "I cannot handle port declarations." + |> Task.fmap (\_ -> Loop state) + + Decl name src -> + let + newState : IO.ReplState + newState = + IO.ReplState imports types (Dict.insert name src decls) + in + Task.fmap Loop (attemptEval env state newState (OutputDecl name)) + + Expr src -> + Task.fmap Loop (attemptEval env state state (OutputExpr src)) + + + +-- ATTEMPT EVAL + + +type Output + = OutputNothing + | OutputDecl N.Name + | OutputExpr String + + +attemptEval : Env -> IO.ReplState -> IO.ReplState -> Output -> Task Never IO.ReplState +attemptEval (Env root interpreter ansi) oldState newState output = + BW.withScope + (\scope -> + Stuff.withRootLock root + (Task.run + (Task.eio Exit.ReplBadDetails + (Details.load Reporting.silent scope root) + |> Task.bind + (\details -> + Task.eio identity + (Build.fromRepl root details (toByteString newState output)) + |> Task.bind + (\artifacts -> + Utils.maybeTraverseTask (Task.mapError Exit.ReplBadGenerate << Generate.repl root details ansi artifacts) (toPrintName output) + ) + ) + ) + ) + ) + |> Task.bind + (\result -> + case result of + Err exit -> + Exit.toStderr (Exit.replToReport exit) + |> Task.fmap (\_ -> oldState) + + Ok Nothing -> + Task.pure newState + + Ok (Just javascript) -> + interpret interpreter javascript + |> Task.fmap + (\exitCode -> + case exitCode of + Exit.ExitSuccess -> + newState + + Exit.ExitFailure _ -> + oldState + ) + ) + + +interpret : FilePath -> String -> Task Never Exit.ExitCode +interpret interpreter javascript = + let + createProcess : { cmdspec : Process.CmdSpec, std_out : Process.StdStream, std_err : Process.StdStream, std_in : Process.StdStream } + createProcess = + Process.proc interpreter [] + |> (\cp -> { cp | std_in = Process.CreatePipe }) + in + Process.withCreateProcess createProcess <| + \stdinHandle _ _ handle -> + case stdinHandle of + Just stdin -> + Utils.builderHPutBuilder stdin javascript + |> Task.bind (\_ -> IO.hClose stdin) + |> Task.bind (\_ -> Process.waitForProcess handle) + + Nothing -> + crash "not implemented" + + + +-- TO BYTESTRING + + +toByteString : IO.ReplState -> Output -> String +toByteString (IO.ReplState imports types decls) output = + String.concat + [ "module " + , N.replModule + , " exposing (..)\n" + , Dict.foldr (\_ -> (++)) "" imports + , Dict.foldr (\_ -> (++)) "" types + , Dict.foldr (\_ -> (++)) "" decls + , outputToBuilder output + ] + + +outputToBuilder : Output -> String +outputToBuilder output = + N.replValueToPrint + ++ " =" + ++ (case output of + OutputNothing -> + " ()\n" + + OutputDecl _ -> + " ()\n" + + OutputExpr expr -> + List.foldr (\line rest -> "\n " ++ line ++ rest) "\n" (Utils.lines expr) + ) + + + +-- TO PRINT NAME + + +toPrintName : Output -> Maybe N.Name +toPrintName output = + case output of + OutputNothing -> + Nothing + + OutputDecl name -> + Just name + + OutputExpr _ -> + Just N.replValueToPrint + + + +-- HELP MESSAGES + + +toHelpMessage : Maybe String -> String +toHelpMessage maybeBadCommand = + case maybeBadCommand of + Nothing -> + genericHelpMessage + + Just command -> + "I do not recognize the :" ++ command ++ " command. " ++ genericHelpMessage + + +genericHelpMessage : String +genericHelpMessage = + "Valid commands include:\n\n :exit Exit the REPL\n :help Show this information\n :reset Clear all previous imports and definitions\n\nMore info at " ++ D.makeLink "repl" ++ "\n" + + + +-- GET ROOT + + +getRoot : Task Never FilePath +getRoot = + Stuff.findRoot + |> Task.bind + (\maybeRoot -> + case maybeRoot of + Just root -> + Task.pure root + + Nothing -> + Stuff.getReplCache + |> Task.bind + (\cache -> + let + root : String + root = + cache ++ "/tmp" + in + Utils.dirCreateDirectoryIfMissing True (root ++ "/src") + |> Task.bind + (\_ -> + Outline.write root <| + Outline.Pkg <| + Outline.PkgOutline + Pkg.dummyName + Outline.defaultSummary + Licenses.bsd3 + V.one + (Outline.ExposedList []) + defaultDeps + Map.empty + C.defaultElm + ) + |> Task.fmap (\_ -> root) + ) + ) + + +defaultDeps : Dict ( String, String ) Pkg.Name C.Constraint +defaultDeps = + Map.fromList identity + [ ( Pkg.core, C.anything ) + , ( Pkg.json, C.anything ) + , ( Pkg.html, C.anything ) + ] + + + +-- GET INTERPRETER + + +getInterpreter : Maybe String -> Task Never FilePath +getInterpreter maybeName = + case maybeName of + Just name -> + getInterpreterHelp name (Utils.dirFindExecutable name) + + Nothing -> + getInterpreterHelp "node` or `nodejs" <| + (Utils.dirFindExecutable "node" + |> Task.bind + (\exe1 -> + Utils.dirFindExecutable "nodejs" + |> Task.fmap (\exe2 -> Maybe.or exe1 exe2) + ) + ) + + +getInterpreterHelp : String -> Task Never (Maybe FilePath) -> Task Never FilePath +getInterpreterHelp name findExe = + findExe + |> Task.bind + (\maybePath -> + case maybePath of + Just path -> + Task.pure path + + Nothing -> + IO.hPutStrLn IO.stderr (exeNotFound name) + |> Task.bind (\_ -> Exit.exitFailure) + ) + + +exeNotFound : String -> String +exeNotFound name = + "The REPL relies on node.js to execute JavaScript code outside the browser.\n" + ++ "I could not find executable `" + ++ name + ++ "` on your PATH though!\n\n" + ++ "You can install node.js from . If it is already installed\n" + ++ "but has a different name, use the --interpreter flag." + + + +-- SETTINGS + + +initSettings : Task Never Utils.ReplSettings +initSettings = + Stuff.getReplCache + |> Task.fmap + (\cache -> + Utils.ReplSettings + { historyFile = Just (cache ++ "/history") + , autoAddHistory = True + , complete = Utils.replCompleteWord Nothing " \n" lookupCompletions + } + ) + + +lookupCompletions : String -> M (List Utils.ReplCompletion) +lookupCompletions string = + State.get + |> State.fmap + (\(IO.ReplState imports types decls) -> + addMatches string False decls <| + addMatches string False types <| + addMatches string True imports <| + addMatches string False commands [] + ) + + +commands : Dict.Dict N.Name () +commands = + Dict.fromList + [ ( ":exit", () ) + , ( ":quit", () ) + , ( ":reset", () ) + , ( ":help", () ) + ] + + +addMatches : String -> Bool -> Dict.Dict N.Name v -> List Utils.ReplCompletion -> List Utils.ReplCompletion +addMatches string isFinished dict completions = + Dict.foldr (addMatch string isFinished) completions dict + + +addMatch : String -> Bool -> N.Name -> v -> List Utils.ReplCompletion -> List Utils.ReplCompletion +addMatch string isFinished name _ completions = + let + suggestion : String + suggestion = + String.fromList (N.toChars name) + in + if String.startsWith string suggestion then + Utils.ReplCompletion suggestion suggestion isFinished :: completions + + else + completions diff --git a/src/Terminal/Terminal.elm b/src/Terminal/Terminal.elm new file mode 100644 index 0000000000..b271128d33 --- /dev/null +++ b/src/Terminal/Terminal.elm @@ -0,0 +1,197 @@ +module Terminal.Terminal exposing + ( app + , flag + , flags + , more + , noArgs + , noFlags + , onOff + , oneOf + , require0 + , require1 + , require2 + , require3 + , zeroOrMore + ) + +import Compiler.Elm.Version as V +import Compiler.Reporting.Doc as D +import List.Extra as List +import System.Exit as Exit +import System.IO as IO +import Task exposing (Task) +import Terminal.Terminal.Error as Error +import Terminal.Terminal.Internal exposing (Args(..), Command(..), CompleteArgs(..), Flag(..), Flags(..), Parser, RequiredArgs(..), toName) +import Utils.Main as Utils +import Utils.Task.Extra as Task + + + +-- APP + + +app : D.Doc -> D.Doc -> List Command -> Task Never () +app intro outro commands = + Utils.envGetArgs + |> Task.bind + (\argStrings -> + case argStrings of + [] -> + Error.exitWithOverview intro outro commands + + [ "--help" ] -> + Error.exitWithOverview intro outro commands + + [ "--version" ] -> + IO.hPutStrLn IO.stdout (V.toChars V.compiler) + |> Task.bind (\_ -> Exit.exitSuccess) + + command :: chunks -> + case List.find (\cmd -> toName cmd == command) commands of + Nothing -> + Error.exitWithUnknown command (List.map toName commands) + + Just (Command _ _ details example args_ flags_ callback) -> + if List.member "--help" chunks then + Error.exitWithHelp (Just command) details example args_ flags_ + + else + case callback chunks of + Ok res -> + res + + Err err -> + Error.exitWithError err + ) + + + +-- FLAGS + + +{-| -} +noFlags : Flags +noFlags = + FDone + + +{-| -} +flags : Flags +flags = + FDone + + +{-| -} +more : Flag -> Flags -> Flags +more f fs = + FMore fs f + + + +-- FLAG + + +{-| -} +flag : String -> Parser -> String -> Flag +flag = + Flag + + +{-| -} +onOff : String -> String -> Flag +onOff = + OnOff + + + +-- FANCY ARGS + + +{-| -} +args : RequiredArgs +args = + Done + + +exactly : RequiredArgs -> Args +exactly requiredArgs = + Args [ Exactly requiredArgs ] + + +exclamantionMark : RequiredArgs -> Parser -> RequiredArgs +exclamantionMark = + Required + + + +-- questionMark : RequiredArgs -> Parser -> Args +-- questionMark requiredArgs optionalArg = +-- Args [ Optional requiredArgs optionalArg ] + + +dotdotdot : RequiredArgs -> Parser -> Args +dotdotdot requiredArgs repeatedArg = + Args [ Multiple requiredArgs repeatedArg ] + + +oneOf : List Args -> Args +oneOf listOfArgs = + Args (List.concatMap (\(Args a) -> a) listOfArgs) + + + +-- -- SIMPLE ARGS + + +noArgs : Args +noArgs = + exactly args + + + +-- required : Parser -> Args +-- required parser = +-- require1 identity parser +-- optional : Parser -> Args +-- optional parser = +-- questionMark args parser + + +zeroOrMore : Parser -> Args +zeroOrMore parser = + dotdotdot args parser + + + +-- oneOrMore : Parser -> Args +-- oneOrMore parser = +-- exclamantionMark args (dotdotdot parser parser) + + +require0 : Args +require0 = + exactly args + + +require1 : Parser -> Args +require1 a = + exactly (exclamantionMark args a) + + +require2 : Parser -> Parser -> Args +require2 a b = + exactly (exclamantionMark (exclamantionMark args a) b) + + +require3 : Parser -> Parser -> Parser -> Args +require3 a b c = + exactly (exclamantionMark (exclamantionMark (exclamantionMark args a) b) c) + + + +-- require4 : (a -> b -> c -> d -> args) -> Parser a -> Parser b -> Parser c -> Parser d -> Args args +-- require4 func a b c d = +-- exactly (exclamantionMark (exclamantionMark (exclamantionMark (exclamantionMark (args func) a) b) c) d) +-- require5 : (a -> b -> c -> d -> e -> args) -> Parser a -> Parser b -> Parser c -> Parser d -> Parser e -> Args args +-- require5 func a b c d e = +-- exactly (exclamantionMark (exclamantionMark (exclamantionMark (exclamantionMark (exclamantionMark (args func) a) b) c) d) e) diff --git a/src/Terminal/Terminal/Chomp.elm b/src/Terminal/Terminal/Chomp.elm new file mode 100644 index 0000000000..767e1b448a --- /dev/null +++ b/src/Terminal/Terminal/Chomp.elm @@ -0,0 +1,481 @@ +module Terminal.Terminal.Chomp exposing + ( Chomper + , Chunk + , Suggest + , apply + , bind + , checkForUnknownFlags + , chomp + , chompArg + , chompExactly + , chompMultiple + , chompNormalFlag + , chompOnOffFlag + , fmap + , pure + ) + +import Basics.Extra exposing (flip) +import Maybe.Extra as Maybe +import Task exposing (Task) +import Terminal.Terminal.Internal exposing (ArgError(..), Error(..), Expectation(..), Flag(..), FlagError(..), Flags(..), Parser(..)) +import Utils.Task.Extra as Task + + + +-- CHOMP INTERFACE + + +chomp : + Maybe Int + -> List String + -> List (Suggest -> List Chunk -> ( Suggest, Result ArgError args )) + -> Chomper FlagError flags + -> ( Task Never (List String), Result Error ( args, flags ) ) +chomp maybeIndex strings args (Chomper flagChomper) = + case flagChomper (toSuggest maybeIndex) (toChunks strings) of + ChomperOk suggest chunks flagValue -> + Tuple.mapSecond (Result.map (\a -> ( a, flagValue ))) (chompArgs suggest chunks args) + + ChomperErr suggest flagError -> + ( addSuggest (Task.pure []) suggest, Err (BadFlag flagError) ) + + +toChunks : List String -> List Chunk +toChunks strings = + List.map2 Chunk + (List.repeat (List.length strings) () + |> List.indexedMap (\i _ -> i) + ) + strings + + +toSuggest : Maybe Int -> Suggest +toSuggest maybeIndex = + case maybeIndex of + Nothing -> + NoSuggestion + + Just index -> + Suggest index + + + +-- CHOMPER + + +type Chomper x a + = Chomper (Suggest -> List Chunk -> ChomperResult x a) + + +type ChomperResult x a + = ChomperOk Suggest (List Chunk) a + | ChomperErr Suggest x + + +type Chunk + = Chunk Int String + + +type Suggest + = NoSuggestion + | Suggest Int + | Suggestions (Task Never (List String)) + + +makeSuggestion : Suggest -> (Int -> Maybe (Task Never (List String))) -> Suggest +makeSuggestion suggest maybeUpdate = + case suggest of + NoSuggestion -> + suggest + + Suggestions _ -> + suggest + + Suggest index -> + Maybe.unwrap suggest Suggestions (maybeUpdate index) + + + +-- ARGS + + +chompArgs : Suggest -> List Chunk -> List (Suggest -> List Chunk -> ( Suggest, Result ArgError a )) -> ( Task Never (List String), Result Error a ) +chompArgs suggest chunks completeArgsList = + chompArgsHelp suggest chunks completeArgsList [] [] + + +chompArgsHelp : + Suggest + -> List Chunk + -> List (Suggest -> List Chunk -> ( Suggest, Result ArgError a )) + -> List Suggest + -> List ArgError + -> ( Task Never (List String), Result Error a ) +chompArgsHelp suggest chunks completeArgsList revSuggest revArgErrors = + case completeArgsList of + [] -> + ( List.foldl (flip addSuggest) (Task.pure []) revSuggest + , Err (BadArgs (List.reverse revArgErrors)) + ) + + completeArgs :: others -> + case completeArgs suggest chunks of + ( s1, Err argError ) -> + chompArgsHelp suggest chunks others (s1 :: revSuggest) (argError :: revArgErrors) + + ( s1, Ok value ) -> + ( addSuggest (Task.pure []) s1 + , Ok value + ) + + +addSuggest : Task Never (List String) -> Suggest -> Task Never (List String) +addSuggest everything suggest = + case suggest of + NoSuggestion -> + everything + + Suggest _ -> + everything + + Suggestions newStuff -> + Task.pure (++) + |> Task.apply newStuff + |> Task.apply everything + + + +-- COMPLETE ARGS + + +chompExactly : Chomper ArgError a -> Suggest -> List Chunk -> ( Suggest, Result ArgError a ) +chompExactly (Chomper chomper) suggest chunks = + case chomper suggest chunks of + ChomperOk s cs value -> + case List.map (\(Chunk _ chunk) -> chunk) cs of + [] -> + ( s, Ok value ) + + es -> + ( s, Err (ArgExtras es) ) + + ChomperErr s argError -> + ( s, Err argError ) + + +chompMultiple : Chomper ArgError (List a -> b) -> Parser -> (String -> Maybe a) -> Suggest -> List Chunk -> ( Suggest, Result ArgError b ) +chompMultiple (Chomper chomper) parser parserFn suggest chunks = + case chomper suggest chunks of + ChomperOk s1 cs func -> + chompMultipleHelp parser parserFn [] s1 cs func + + ChomperErr s1 argError -> + ( s1, Err argError ) + + +chompMultipleHelp : Parser -> (String -> Maybe a) -> List a -> Suggest -> List Chunk -> (List a -> b) -> ( Suggest, Result ArgError b ) +chompMultipleHelp parser parserFn revArgs suggest chunks func = + case chunks of + [] -> + ( suggest, Ok (func (List.reverse revArgs)) ) + + (Chunk index string) :: otherChunks -> + case tryToParse suggest parser parserFn index string of + ( s1, Err expectation ) -> + ( s1, Err (ArgBad string expectation) ) + + ( s1, Ok arg ) -> + chompMultipleHelp parser parserFn (arg :: revArgs) s1 otherChunks func + + + +-- REQUIRED ARGS + + +chompArg : Int -> Parser -> (String -> Maybe a) -> Chomper ArgError a +chompArg numChunks ((Parser { singular, examples }) as parser) parserFn = + Chomper <| + \suggest chunks -> + case chunks of + [] -> + let + newSuggest : Suggest + newSuggest = + makeSuggestion suggest (suggestArg parser numChunks) + + theError : ArgError + theError = + ArgMissing (Expectation singular (examples "")) + in + ChomperErr newSuggest theError + + (Chunk index string) :: otherChunks -> + case tryToParse suggest parser parserFn index string of + ( newSuggest, Err expectation ) -> + ChomperErr newSuggest (ArgBad string expectation) + + ( newSuggest, Ok arg ) -> + ChomperOk newSuggest otherChunks arg + + +suggestArg : Parser -> Int -> Int -> Maybe (Task Never (List String)) +suggestArg (Parser { suggest }) numChunks targetIndex = + if numChunks <= targetIndex then + Just (suggest "") + + else + Nothing + + + +-- PARSER + + +tryToParse : Suggest -> Parser -> (String -> Maybe a) -> Int -> String -> ( Suggest, Result Expectation a ) +tryToParse suggest (Parser parser) parserFn index string = + let + newSuggest : Suggest + newSuggest = + makeSuggestion suggest <| + \targetIndex -> + if index == targetIndex then + Just (parser.suggest string) + + else + Nothing + + outcome : Result Expectation a + outcome = + case parserFn string of + Nothing -> + Err (Expectation parser.singular (parser.examples string)) + + Just value -> + Ok value + in + ( newSuggest, outcome ) + + + +-- FLAG + + +chompOnOffFlag : String -> Chomper FlagError Bool +chompOnOffFlag flagName = + Chomper <| + \suggest chunks -> + case findFlag flagName chunks of + Nothing -> + ChomperOk suggest chunks False + + Just (FoundFlag before value after) -> + case value of + DefNope -> + ChomperOk suggest (before ++ after) True + + Possibly chunk -> + ChomperOk suggest (before ++ chunk :: after) True + + Definitely _ string -> + ChomperErr suggest (FlagWithValue flagName string) + + +chompNormalFlag : String -> Parser -> (String -> Maybe a) -> Chomper FlagError (Maybe a) +chompNormalFlag flagName ((Parser { singular, examples }) as parser) parserFn = + Chomper <| + \suggest chunks -> + case findFlag flagName chunks of + Nothing -> + ChomperOk suggest chunks Nothing + + Just (FoundFlag before value after) -> + let + attempt : Int -> String -> ChomperResult FlagError (Maybe a) + attempt index string = + case tryToParse suggest parser parserFn index string of + ( newSuggest, Err expectation ) -> + ChomperErr newSuggest (FlagWithBadValue flagName string expectation) + + ( newSuggest, Ok flagValue ) -> + ChomperOk newSuggest (before ++ after) (Just flagValue) + in + case value of + Definitely index string -> + attempt index string + + Possibly (Chunk index string) -> + attempt index string + + DefNope -> + ChomperErr suggest (FlagWithNoValue flagName (Expectation singular (examples ""))) + + + +-- FIND FLAG + + +type FoundFlag + = FoundFlag (List Chunk) Value (List Chunk) + + +type Value + = Definitely Int String + | Possibly Chunk + | DefNope + + +findFlag : String -> List Chunk -> Maybe FoundFlag +findFlag flagName chunks = + findFlagHelp [] ("--" ++ flagName) ("--" ++ flagName ++ "=") chunks + + +findFlagHelp : List Chunk -> String -> String -> List Chunk -> Maybe FoundFlag +findFlagHelp revPrev loneFlag flagPrefix chunks = + let + succeed : Value -> List Chunk -> Maybe FoundFlag + succeed value after = + Just (FoundFlag (List.reverse revPrev) value after) + + deprefix : String -> String + deprefix string = + String.dropLeft (String.length flagPrefix) string + in + case chunks of + [] -> + Nothing + + ((Chunk index string) as chunk) :: rest -> + if String.startsWith flagPrefix string then + succeed (Definitely index (deprefix string)) rest + + else if string /= loneFlag then + findFlagHelp (chunk :: revPrev) loneFlag flagPrefix rest + + else + case rest of + [] -> + succeed DefNope [] + + ((Chunk _ potentialArg) as argChunk) :: restOfRest -> + if String.startsWith "-" potentialArg then + succeed DefNope rest + + else + succeed (Possibly argChunk) restOfRest + + + +-- CHECK FOR UNKNOWN FLAGS + + +checkForUnknownFlags : Flags -> Chomper FlagError () +checkForUnknownFlags flags = + Chomper <| + \suggest chunks -> + case List.filter startsWithDash chunks of + [] -> + ChomperOk suggest chunks () + + ((Chunk _ unknownFlag) :: _) as unknownFlags -> + ChomperErr + (makeSuggestion suggest (suggestFlag unknownFlags flags)) + (FlagUnknown unknownFlag flags) + + +suggestFlag : List Chunk -> Flags -> Int -> Maybe (Task Never (List String)) +suggestFlag unknownFlags flags targetIndex = + case unknownFlags of + [] -> + Nothing + + (Chunk index string) :: otherUnknownFlags -> + if index == targetIndex then + Just (Task.pure (List.filter (String.startsWith string) (getFlagNames flags []))) + + else + suggestFlag otherUnknownFlags flags targetIndex + + +startsWithDash : Chunk -> Bool +startsWithDash (Chunk _ string) = + String.startsWith "-" string + + +getFlagNames : Flags -> List String -> List String +getFlagNames flags names = + case flags of + FDone -> + "--help" :: names + + FMore subFlags flag -> + getFlagNames subFlags (getFlagName flag :: names) + + +getFlagName : Flag -> String +getFlagName flag = + case flag of + Flag name _ _ -> + "--" ++ name + + OnOff name _ -> + "--" ++ name + + + +-- CHOMPER INSTANCES + + +fmap : (a -> b) -> Chomper x a -> Chomper x b +fmap func (Chomper chomper) = + Chomper <| + \i w -> + case chomper i w of + ChomperOk s1 cs1 value -> + ChomperOk s1 cs1 (func value) + + ChomperErr sErr e -> + ChomperErr sErr e + + +pure : a -> Chomper x a +pure value = + Chomper <| + \ss cs -> + ChomperOk ss cs value + + +apply : Chomper x a -> Chomper x (a -> b) -> Chomper x b +apply (Chomper argChomper) (Chomper funcChomper) = + Chomper <| + \s cs -> + let + ok1 : Suggest -> List Chunk -> (a -> b) -> ChomperResult x b + ok1 s1 cs1 func = + case argChomper s1 cs1 of + ChomperOk s2 cs2 value -> + ChomperOk s2 cs2 (func value) + + ChomperErr s2 err -> + ChomperErr s2 err + in + case funcChomper s cs of + ChomperOk s1 cs1 func -> + ok1 s1 cs1 func + + ChomperErr s1 err -> + ChomperErr s1 err + + +bind : (a -> Chomper x b) -> Chomper x a -> Chomper x b +bind callback (Chomper aChomper) = + Chomper <| + \s cs -> + case aChomper s cs of + ChomperOk s1 cs1 a -> + case callback a of + Chomper bChomper -> + bChomper s1 cs1 + + ChomperErr sErr e -> + ChomperErr sErr e diff --git a/src/Terminal/Terminal/Error.elm b/src/Terminal/Terminal/Error.elm new file mode 100644 index 0000000000..5bcbc4c13b --- /dev/null +++ b/src/Terminal/Terminal/Error.elm @@ -0,0 +1,580 @@ +module Terminal.Terminal.Error exposing + ( exitWithError + , exitWithHelp + , exitWithOverview + , exitWithUnknown + ) + +import Compiler.Reporting.Suggest as Suggest +import List.Extra as List +import Prelude +import System.Exit as Exit +import System.IO as IO +import Task exposing (Task) +import Terminal.Terminal.Internal + exposing + ( ArgError(..) + , Args(..) + , Command(..) + , CompleteArgs(..) + , Error(..) + , Expectation(..) + , Flag(..) + , FlagError(..) + , Flags(..) + , Parser(..) + , RequiredArgs(..) + , Summary(..) + , toName + ) +import Text.PrettyPrint.ANSI.Leijen as P +import Utils.Main as Utils +import Utils.Task.Extra as Task + + + +-- EXIT + + +exitSuccess : List P.Doc -> Task Never a +exitSuccess = + exitWith Exit.ExitSuccess + + +exitFailure : List P.Doc -> Task Never a +exitFailure = + exitWith (Exit.ExitFailure 1) + + +exitWith : Exit.ExitCode -> List P.Doc -> Task Never a +exitWith code docs = + IO.hIsTerminalDevice IO.stderr + |> Task.bind + (\isTerminal -> + let + adjust : P.Doc -> P.Doc + adjust = + if isTerminal then + identity + + else + P.plain + in + P.displayIO IO.stderr + (P.renderPretty 1 + 80 + (adjust (P.vcat (List.concatMap (\d -> [ d, P.text "" ]) docs))) + ) + |> Task.bind (\_ -> IO.hPutStrLn IO.stderr "") + |> Task.bind (\_ -> Exit.exitWith code) + ) + + +getExeName : Task Never String +getExeName = + Task.fmap Utils.fpTakeFileName Utils.envGetProgName + + +stack : List P.Doc -> P.Doc +stack docs = + P.vcat <| List.intersperse (P.text "") docs + + +reflow : String -> P.Doc +reflow string = + P.fillSep <| List.map P.text <| String.words string + + + +-- HELP + + +exitWithHelp : Maybe String -> String -> P.Doc -> Args -> Flags -> Task Never a +exitWithHelp maybeCommand details example (Args args) flags = + toCommand maybeCommand + |> Task.bind + (\command -> + exitSuccess <| + [ reflow details + , P.indent 4 <| P.cyan <| P.vcat <| List.map (argsToDoc command) args + , example + ] + ++ (case flagsToDocs flags [] of + [] -> + [] + + (_ :: _) as docs -> + [ P.text "You can customize this command with the following flags:" + , P.indent 4 <| stack docs + ] + ) + ) + + +toCommand : Maybe String -> Task Never String +toCommand maybeCommand = + getExeName + |> Task.fmap + (\exeName -> + case maybeCommand of + Nothing -> + exeName + + Just command -> + exeName ++ " " ++ command + ) + + +argsToDoc : String -> CompleteArgs -> P.Doc +argsToDoc command args = + case args of + Exactly required -> + argsToDocHelp command required [] + + Multiple required (Parser { plural }) -> + argsToDocHelp command required [ "zero or more " ++ plural ] + + +argsToDocHelp : String -> RequiredArgs -> List String -> P.Doc +argsToDocHelp command args names = + case args of + Done -> + P.hang 4 <| + P.hsep <| + List.map P.text <| + (command :: List.map toToken names) + + Required others (Parser { singular }) -> + argsToDocHelp command others (singular :: names) + + +toToken : String -> String +toToken string = + "<" + ++ String.map + (\c -> + if c == ' ' then + '-' + + else + c + ) + string + ++ ">" + + +flagsToDocs : Flags -> List P.Doc -> List P.Doc +flagsToDocs flags docs = + case flags of + FDone -> + docs + + FMore more flag -> + let + flagDoc : P.Doc + flagDoc = + P.vcat <| + case flag of + Flag name (Parser { singular }) description -> + [ P.dullcyan <| P.text <| "--" ++ name ++ "=" ++ toToken singular + , P.indent 4 <| reflow description + ] + + OnOff name description -> + [ P.dullcyan <| P.text <| "--" ++ name + , P.indent 4 <| reflow description + ] + in + flagsToDocs more (flagDoc :: docs) + + + +-- OVERVIEW + + +exitWithOverview : P.Doc -> P.Doc -> List Command -> Task Never a +exitWithOverview intro outro commands = + getExeName + |> Task.bind + (\exeName -> + exitSuccess + [ intro + , P.text "The most common commands are:" + , P.indent 4 <| stack <| List.filterMap (toSummary exeName) commands + , P.text "There are a bunch of other commands as well though. Here is a full list:" + , P.indent 4 <| P.dullcyan <| toCommandList exeName commands + , P.text "Adding the --help flag gives a bunch of additional details about each one." + , outro + ] + ) + + +toSummary : String -> Command -> Maybe P.Doc +toSummary exeName (Command name summary _ _ (Args args) _ _) = + case summary of + Uncommon -> + Nothing + + Common summaryString -> + Just <| + P.vcat + [ P.cyan <| argsToDoc (exeName ++ " " ++ name) (Prelude.head args) + , P.indent 4 <| reflow summaryString + ] + + +toCommandList : String -> List Command -> P.Doc +toCommandList exeName commands = + let + names : List String + names = + List.map toName commands + + width : Int + width = + Utils.listMaximum compare (List.map String.length names) + + toExample : String -> P.Doc + toExample name = + P.text + (exeName + ++ " " + ++ name + ++ String.repeat (width - String.length name) " " + ++ " --help" + ) + in + P.vcat (List.map toExample names) + + + +-- UNKNOWN + + +exitWithUnknown : String -> List String -> Task Never a +exitWithUnknown unknown knowns = + let + nearbyKnowns : List ( Int, String ) + nearbyKnowns = + List.takeWhile (\( r, _ ) -> r <= 3) (Suggest.rank unknown identity knowns) + + suggestions : List P.Doc + suggestions = + case List.map toGreen (List.map Tuple.second nearbyKnowns) of + [] -> + [] + + [ nearby ] -> + [ P.text "Try", nearby, P.text "instead?" ] + + [ a, b ] -> + [ P.text "Try", a, P.text "or", b, P.text "instead?" ] + + (_ :: _ :: _ :: _) as abcs -> + P.text "Try" + :: List.map (P.a (P.text ",")) (Prelude.init abcs) + ++ [ P.text "or", Prelude.last abcs, P.text "instead?" ] + in + getExeName + |> Task.bind + (\exeName -> + exitFailure + [ P.fillSep <| + [ P.text "There" + , P.text "is" + , P.text "no" + , toRed unknown + , P.text "command." + ] + ++ suggestions + , reflow <| "Run `" ++ exeName ++ "` with no arguments to get more hints." + ] + ) + + + +-- ERROR TO DOC + + +exitWithError : Error -> Task Never a +exitWithError err = + Task.bind exitFailure + (case err of + BadFlag flagError -> + flagErrorToDocs flagError + + BadArgs argErrors -> + case argErrors of + [] -> + Task.pure + [ reflow <| "I was not expecting any arguments for this command." + , reflow <| "Try removing them?" + ] + + [ argError ] -> + argErrorToDocs argError + + _ :: _ :: _ -> + argErrorToDocs <| Prelude.head <| List.sortBy toArgErrorRank argErrors + ) + + +toArgErrorRank : + ArgError + -> Int -- lower is better +toArgErrorRank err = + case err of + ArgBad _ _ -> + 0 + + ArgMissing _ -> + 1 + + ArgExtras _ -> + 2 + + +toGreen : String -> P.Doc +toGreen str = + P.green (P.text str) + + +toYellow : String -> P.Doc +toYellow str = + P.yellow (P.text str) + + +toRed : String -> P.Doc +toRed str = + P.red (P.text str) + + + +-- ARG ERROR TO DOC + + +argErrorToDocs : ArgError -> Task Never (List P.Doc) +argErrorToDocs argError = + case argError of + ArgMissing (Expectation tipe makeExamples) -> + makeExamples + |> Task.fmap + (\examples -> + [ P.fillSep + [ P.text "The" + , P.text "arguments" + , P.text "you" + , P.text "have" + , P.text "are" + , P.text "fine," + , P.text "but" + , P.text "in" + , P.text "addition," + , P.text "I" + , P.text "was" + , P.text "expecting" + , P.text "a" + , toYellow (toToken tipe) + , P.text "value." + , P.text "For" + , P.text "example:" + ] + , P.indent 4 <| P.green <| P.vcat <| List.map P.text examples + ] + ) + + ArgBad string (Expectation tipe makeExamples) -> + makeExamples + |> Task.fmap + (\examples -> + [ P.text "I am having trouble with this argument:" + , P.indent 4 <| toRed string + , P.fillSep <| + [ P.text "It" + , P.text "is" + , P.text "supposed" + , P.text "to" + , P.text "be" + , P.text "a" + , toYellow (toToken tipe) + , P.text "value," + , P.text "like" + ] + ++ (if List.length examples == 1 then + [ P.text "this:" ] + + else + [ P.text "one" + , P.text "of" + , P.text "these:" + ] + ) + , P.indent 4 <| P.green <| P.vcat <| List.map P.text examples + ] + ) + + ArgExtras extras -> + let + ( these, them ) = + case extras of + [ _ ] -> + ( "this argument", "it" ) + + _ -> + ( "these arguments", "them" ) + in + Task.pure + [ reflow <| "I was not expecting " ++ these ++ ":" + , P.indent 4 <| P.red <| P.vcat <| List.map P.text extras + , reflow <| "Try removing " ++ them ++ "?" + ] + + + +-- FLAG ERROR TO DOC + + +flagErrorHelp : String -> String -> List P.Doc -> Task Never (List P.Doc) +flagErrorHelp summary original explanation = + Task.pure <| + [ reflow summary + , P.indent 4 (toRed original) + ] + ++ explanation + + +flagErrorToDocs : FlagError -> Task Never (List P.Doc) +flagErrorToDocs flagError = + case flagError of + FlagWithValue flagName value -> + flagErrorHelp + "This on/off flag was given a value:" + ("--" ++ flagName ++ "=" ++ value) + [ P.text "An on/off flag either exists or not. It cannot have an equals sign and value.\nMaybe you want this instead?" + , P.indent 4 <| toGreen <| "--" ++ flagName + ] + + FlagWithNoValue flagName (Expectation tipe makeExamples) -> + makeExamples + |> Task.bind + (\examples -> + flagErrorHelp + "This flag needs more information:" + ("--" ++ flagName) + [ P.fillSep + [ P.text "It" + , P.text "needs" + , P.text "a" + , toYellow (toToken tipe) + , P.text "like" + , P.text "this:" + ] + , P.indent 4 <| + P.vcat <| + List.map toGreen <| + case List.take 4 examples of + [] -> + [ "--" ++ flagName ++ "=" ++ toToken tipe ] + + _ :: _ -> + List.map (\example -> "--" ++ flagName ++ "=" ++ example) examples + ] + ) + + FlagWithBadValue flagName badValue (Expectation tipe makeExamples) -> + makeExamples + |> Task.bind + (\examples -> + flagErrorHelp + "This flag was given a bad value:" + ("--" ++ flagName ++ "=" ++ badValue) + [ P.fillSep <| + [ P.text "I" + , P.text "need" + , P.text "a" + , P.text "valid" + , toYellow (toToken tipe) + , P.text "value." + , P.text "For" + , P.text "example:" + ] + , P.indent 4 <| + P.vcat <| + List.map toGreen <| + case List.take 4 examples of + [] -> + [ "--" ++ flagName ++ "=" ++ toToken tipe ] + + _ :: _ -> + List.map (\example -> "--" ++ flagName ++ "=" ++ example) examples + ] + ) + + FlagUnknown unknown flags -> + flagErrorHelp "I do not recognize this flag:" + unknown + (let + unknownName : String + unknownName = + List.takeWhile ((/=) '=') (List.dropWhile ((==) '-') (String.toList unknown)) + |> String.fromList + in + case getNearbyFlags unknownName flags [] of + [] -> + [] + + [ thisOne ] -> + [ P.fillSep + [ P.text "Maybe" + , P.text "you" + , P.text "want" + , P.green thisOne + , P.text "instead?" + ] + ] + + suggestions -> + [ P.fillSep + [ P.text "Maybe" + , P.text "you" + , P.text "want" + , P.text "one" + , P.text "of" + , P.text "these" + , P.text "instead?" + ] + , P.indent 4 <| P.green <| P.vcat suggestions + ] + ) + + +getNearbyFlags : String -> Flags -> List ( Int, String ) -> List P.Doc +getNearbyFlags unknown flags unsortedFlags = + case flags of + FDone -> + List.map P.text <| + List.map Tuple.second <| + List.sortBy Tuple.first <| + case List.filter (\( d, _ ) -> d < 3) unsortedFlags of + [] -> + unsortedFlags + + nearbyUnsortedFlags -> + nearbyUnsortedFlags + + FMore more flag -> + getNearbyFlags unknown more (getNearbyFlagsHelp unknown flag :: unsortedFlags) + + +getNearbyFlagsHelp : String -> Flag -> ( Int, String ) +getNearbyFlagsHelp unknown flag = + case flag of + OnOff flagName _ -> + ( Suggest.distance unknown flagName + , "--" ++ flagName + ) + + Flag flagName (Parser { singular }) _ -> + ( Suggest.distance unknown flagName + , "--" ++ flagName ++ "=" ++ toToken singular + ) diff --git a/src/Terminal/Terminal/Helpers.elm b/src/Terminal/Terminal/Helpers.elm new file mode 100644 index 0000000000..67dcb0acd7 --- /dev/null +++ b/src/Terminal/Terminal/Helpers.elm @@ -0,0 +1,202 @@ +module Terminal.Terminal.Helpers exposing + ( filePath + , guidaOrElmFile + , package + , parseFilePath + , parseGuidaOrElmFile + , parsePackage + , parseVersion + , version + ) + +import Builder.Deps.Registry as Registry +import Builder.Stuff as Stuff +import Compiler.Elm.Package as Pkg +import Compiler.Elm.Version as V +import Compiler.Parse.Primitives as P +import Compiler.Reporting.Suggest as Suggest +import Data.Map as Dict +import Task exposing (Task) +import Terminal.Terminal.Internal exposing (Parser(..)) +import Utils.Main as Utils exposing (FilePath) +import Utils.Task.Extra as Task + + + +-- VERSION + + +version : Parser +version = + Parser + { singular = "version" + , plural = "versions" + , suggest = suggestVersion + , examples = Task.pure << exampleVersions + } + + +parseVersion : String -> Maybe V.Version +parseVersion chars = + case P.fromByteString V.parser Tuple.pair chars of + Ok vsn -> + Just vsn + + Err _ -> + Nothing + + +suggestVersion : String -> Task Never (List String) +suggestVersion _ = + Task.pure [] + + +exampleVersions : String -> List String +exampleVersions chars = + let + chunks : List String + chunks = + String.split "." chars + + isNumber : String -> Bool + isNumber cs = + not (String.isEmpty cs) && String.all Char.isDigit cs + in + if List.all isNumber chunks then + case chunks of + [ x ] -> + [ x ++ ".0.0" ] + + [ x, y ] -> + [ x ++ "." ++ y ++ ".0" ] + + x :: y :: z :: _ -> + [ x ++ "." ++ y ++ "." ++ z ] + + _ -> + [ "1.0.0", "2.0.3" ] + + else + [ "1.0.0", "2.0.3" ] + + + +-- GUIDA OR ELM FILE + + +guidaOrElmFile : Parser +guidaOrElmFile = + Parser + { singular = "guida or elm file" + , plural = "guida or elm files" + , suggest = \_ -> Task.pure [] + , examples = exampleGuidaOrElmFiles + } + + +parseGuidaOrElmFile : String -> Maybe FilePath +parseGuidaOrElmFile chars = + case Utils.fpTakeExtension chars of + ".guida" -> + Just chars + + ".elm" -> + Just chars + + _ -> + Nothing + + +exampleGuidaOrElmFiles : String -> Task Never (List String) +exampleGuidaOrElmFiles _ = + Task.pure [ "Main.guida", "src/Main.guida", "Main.elm" ] + + + +-- FILE PATH + + +filePath : Parser +filePath = + Parser + { singular = "file path" + , plural = "file paths" + , suggest = \_ -> Task.pure [] + , examples = exampleFilePaths + } + + +parseFilePath : String -> Maybe FilePath +parseFilePath = + Just + + +exampleFilePaths : String -> Task Never (List String) +exampleFilePaths _ = + Task.pure [ "Main.elm", "src" ] + + + +-- PACKAGE + + +package : Parser +package = + Parser + { singular = "package" + , plural = "packages" + , suggest = suggestPackages + , examples = examplePackages + } + + +parsePackage : String -> Maybe Pkg.Name +parsePackage chars = + case P.fromByteString Pkg.parser Tuple.pair chars of + Ok pkg -> + Just pkg + + Err _ -> + Nothing + + +suggestPackages : String -> Task Never (List String) +suggestPackages given = + Stuff.getPackageCache + |> Task.bind + (\cache -> + Registry.read cache + |> Task.fmap + (\maybeRegistry -> + case maybeRegistry of + Nothing -> + [] + + Just (Registry.Registry _ versions) -> + List.filter (String.startsWith given) <| + List.map Pkg.toChars (Dict.keys compare versions) + ) + ) + + +examplePackages : String -> Task Never (List String) +examplePackages given = + Stuff.getPackageCache + |> Task.bind + (\cache -> + Registry.read cache + |> Task.fmap + (\maybeRegistry -> + case maybeRegistry of + Nothing -> + [ "elm/json" + , "elm/http" + , "elm/random" + ] + + Just (Registry.Registry _ versions) -> + List.map Pkg.toChars <| + List.take 4 <| + Suggest.sort given Pkg.toChars (Dict.keys compare versions) + ) + ) diff --git a/src/Terminal/Terminal/Internal.elm b/src/Terminal/Terminal/Internal.elm new file mode 100644 index 0000000000..8106d4d447 --- /dev/null +++ b/src/Terminal/Terminal/Internal.elm @@ -0,0 +1,114 @@ +module Terminal.Terminal.Internal exposing + ( ArgError(..) + , Args(..) + , Command(..) + , CompleteArgs(..) + , Error(..) + , Expectation(..) + , Flag(..) + , FlagError(..) + , Flags(..) + , Parser(..) + , RequiredArgs(..) + , Summary(..) + , toName + ) + +import Task exposing (Task) +import Text.PrettyPrint.ANSI.Leijen exposing (Doc) + + + +-- COMMAND + + +type Command + = Command String Summary String Doc Args Flags (List String -> Result Error (Task Never ())) + + +toName : Command -> String +toName (Command name _ _ _ _ _ _) = + name + + +{-| The information that shows when you run the executable with no arguments. +If you say it is `Common`, you need to tell people what it does. Try to keep +it to two or three lines. If you say it is `Uncommon` you can rely on `Details` +for a more complete explanation. +-} +type Summary + = Common String + | Uncommon + + + +-- FLAGS + + +type Flags + = FDone + | FMore Flags Flag + + +type Flag + = Flag String Parser String + | OnOff String String + + + +-- PARSERS + + +type Parser + = Parser + { singular : String + , plural : String + + -- ,parser : String -> Maybe a + , suggest : String -> Task Never (List String) + , examples : String -> Task Never (List String) + } + + + +-- ARGS + + +type Args + = Args (List CompleteArgs) + + +type CompleteArgs + = Exactly RequiredArgs + | Multiple RequiredArgs Parser + + +type RequiredArgs + = Done + | Required RequiredArgs Parser + + + +-- ERROR + + +type Error + = BadArgs (List ArgError) + | BadFlag FlagError + + +type ArgError + = ArgMissing Expectation + | ArgBad String Expectation + | ArgExtras (List String) + + +type FlagError + = FlagWithValue String String + | FlagWithBadValue String String Expectation + | FlagWithNoValue String Expectation + | FlagUnknown String Flags + + +type Expectation + = Expectation String (Task Never (List String)) diff --git a/src/Terminal/Test.elm b/src/Terminal/Test.elm new file mode 100644 index 0000000000..ff17e05f30 --- /dev/null +++ b/src/Terminal/Test.elm @@ -0,0 +1,1142 @@ +module Terminal.Test exposing + ( Flags(..) + , Report(..) + , format + , parseReport + , run + ) + +import Builder.BackgroundWriter as BW +import Builder.Build as Build +import Builder.Deps.Registry as Registry +import Builder.Deps.Solver as Solver +import Builder.Elm.Details as Details +import Builder.Elm.Outline as Outline +import Builder.File as File +import Builder.Generate as Generate +import Builder.Reporting as Reporting +import Builder.Reporting.Exit as Exit +import Builder.Stuff as Stuff +import Compiler.AST.Source as Src +import Compiler.Data.Name exposing (Name) +import Compiler.Data.NonEmptyList as NE +import Compiler.Elm.Constraint as C +import Compiler.Elm.Package as Pkg +import Compiler.Elm.Version as V +import Compiler.Parse.Module as Parse +import Compiler.Parse.SyntaxVersion as SV +import Compiler.Reporting.Annotation as A +import Data.Map as Dict exposing (Dict) +import Json.Encode as Encode +import Maybe.Extra as Maybe +import Regex exposing (Regex) +import System.Exit as Exit +import System.IO as IO +import System.Process as Process +import Task exposing (Task) +import Terminal.Terminal.Internal exposing (Parser(..)) +import Utils.Crash exposing (crash) +import Utils.Main as Utils exposing (FilePath) +import Utils.Task.Extra as Task + + + +-- RUN + + +type Flags + = Flags (Maybe Int) (Maybe Int) (Maybe Report) + + +run : List String -> Flags -> Task Never () +run paths flags = + Stuff.findRoot + |> Task.bind + (\maybeRoot -> + Reporting.attemptWithStyle style Exit.testToReport <| + case maybeRoot of + Just root -> + runHelp root paths flags + + Nothing -> + Task.pure (Err Exit.TestNoOutline) + ) + + +runHelp : String -> List String -> Flags -> Task Never (Result Exit.Test ()) +runHelp root testFileGlobs flags = + Stuff.withRootLock root <| + Task.run <| + (Utils.dirCreateDirectoryIfMissing True (Stuff.testDir root) + |> Task.bind (\_ -> Utils.nodeGetDirname) + |> Task.io + |> Task.bind + (\nodeDirname -> + Task.eio Exit.TestBadOutline (Outline.read root) + |> Task.bind + (\baseOutline -> + Task.io (Utils.dirDoesDirectoryExist "tests") + |> Task.bind + (\testsDirExists -> + Task.eio Exit.TestBadRegistry Solver.initEnv + |> Task.bind + (\env -> + let + addOptionalTests : NE.Nonempty Outline.SrcDir -> NE.Nonempty Outline.SrcDir + addOptionalTests = + if testsDirExists then + NE.cons (Outline.RelativeSrcDir "tests") + + else + identity + + newSrcDirs : NE.Nonempty Outline.SrcDir -> NE.Nonempty Outline.SrcDir + newSrcDirs srcDirs = + srcDirs + |> addOptionalTests + |> NE.map + (\srcDir -> + case srcDir of + Outline.AbsoluteSrcDir _ -> + srcDir + + Outline.RelativeSrcDir path -> + Outline.RelativeSrcDir ("../../../" ++ path) + ) + |> NE.cons (Outline.AbsoluteSrcDir (Utils.fpCombine nodeDirname "../libraries/test/src")) + |> NE.cons (Outline.RelativeSrcDir "src") + in + case baseOutline of + Outline.App (Outline.AppOutline elm srcDirs depsDirect depsTrans testDirect testTrans) -> + Outline.AppOutline elm (newSrcDirs srcDirs) (Dict.union depsDirect testDirect) (Dict.union depsTrans testTrans) Dict.empty Dict.empty + |> makeAppPlan env Pkg.core + |> Task.bind (makeAppPlan env Pkg.json) + |> Task.bind (makeAppPlan env Pkg.time) + |> Task.bind (makeAppPlan env Pkg.random) + -- TODO changes should only be done to the `tests/elm.json` in case the top level `elm.json` had changes! This will improve performance! + |> Task.bind (attemptChanges root env) + + Outline.Pkg (Outline.PkgOutline _ _ _ _ _ deps test _) -> + Outline.AppOutline V.elmCompiler (newSrcDirs (NE.singleton (Outline.RelativeSrcDir "src"))) Dict.empty Dict.empty Dict.empty Dict.empty + |> makePkgPlan env (Dict.union deps test) + |> Task.bind (makeAppPlan env Pkg.core) + |> Task.bind (makeAppPlan env Pkg.json) + |> Task.bind (makeAppPlan env Pkg.time) + |> Task.bind (makeAppPlan env Pkg.random) + -- TODO changes should only be done to the `tests/elm.json` in case the top level `elm.json` had changes! This will improve performance! + |> Task.bind (attemptChanges root env) + ) + ) + ) + |> Task.bind + (\_ -> + let + paths : List String + paths = + case testFileGlobs of + [] -> + [ root ++ "/tests" ] + + _ -> + testFileGlobs + in + resolveElmFiles paths + |> Task.bind + (\resolvedInputFiles -> + case resolvedInputFiles of + Ok inputFiles -> + inputFiles + |> Utils.listTraverse + (\inputFile -> + case List.filter (\path -> String.startsWith path inputFile) paths of + _ :: [] -> + extractExposedPossiblyTests inputFile + |> Task.fmap (Maybe.map (Tuple.pair inputFile)) + + _ -> + Task.pure Nothing + ) + + Err _ -> + Task.pure [] + ) + |> Task.fmap (List.filterMap identity) + |> Task.bind + (\exposedList -> + Utils.dirCreateDirectoryIfMissing True (Stuff.testDir root ++ "/src/Test/Generated") + |> Task.bind + (\_ -> + let + testModules : List { moduleName : String, possiblyTests : List String } + testModules = + List.map + (\( _, ( moduleName, possiblyTests ) ) -> + { moduleName = moduleName + , possiblyTests = possiblyTests + } + ) + exposedList + in + testGeneratedMain testModules testFileGlobs (List.map Tuple.first exposedList) flags + ) + |> Task.bind (IO.writeString (Stuff.testDir root ++ "/src/Test/Generated/Main.elm")) + |> Task.bind (\_ -> Reporting.terminal) + |> Task.bind + (\terminalStyle -> + Reporting.attemptWithStyle terminalStyle Exit.testToReport <| + Utils.dirWithCurrentDirectory (Stuff.testDir root) + (runMake (Stuff.testDir root) "src/Test/Generated/Main.elm") + ) + |> Task.bind + (\content -> + IO.hPutStrLn IO.stdout "Starting tests" + |> Task.bind + (\_ -> + getInterpreter + |> Task.bind + (\interpreter -> + let + finalContent : String + finalContent = + before + ++ "\nvar Elm = (function(module) {\n" + ++ addKernelTestChecking content + ++ "\nreturn this.Elm;\n})({});\n" + ++ after + in + interpret interpreter finalContent + ) + ) + ) + ) + |> Task.io + ) + |> Task.fmap (\_ -> ()) + ) + ) + + +interpret : FilePath -> String -> Task Never Exit.ExitCode +interpret interpreter javascript = + let + createProcess : { cmdspec : Process.CmdSpec, std_out : Process.StdStream, std_err : Process.StdStream, std_in : Process.StdStream } + createProcess = + Process.proc interpreter [] + |> (\cp -> { cp | std_in = Process.CreatePipe }) + in + Process.withCreateProcess createProcess <| + \stdinHandle _ _ handle -> + case stdinHandle of + Just stdin -> + Utils.builderHPutBuilder stdin javascript + |> Task.bind (\_ -> IO.hClose stdin) + |> Task.bind (\_ -> Process.waitForProcess handle) + + Nothing -> + crash "not implemented" + + +testVariantDefinition : Regex +testVariantDefinition = + Maybe.withDefault Regex.never <| + Regex.fromStringWith { caseInsensitive = False, multiline = True } + "^var\\s+\\$elm_explorations\\$test\\$Test\\$Internal\\$(?:ElmTestVariant__\\w+|UnitTest|FuzzTest|Labeled|Skipped|Only|Batch)\\s*=\\s*(?:\\w+\\(\\s*)?function\\s*\\([\\w, ]*\\)\\s*\\{\\s*return *\\{" + + +checkDefinition : Regex +checkDefinition = + Maybe.withDefault Regex.never <| + Regex.fromStringWith { caseInsensitive = False, multiline = True } + "^(var\\s+\\$author\\$project\\$Test\\$Runner\\$Node\\$check)\\s*=\\s*\\$author\\$project\\$Test\\$Runner\\$Node\\$checkHelperReplaceMe___;?$" + + +addKernelTestChecking : String -> String +addKernelTestChecking content = + "var __elmTestSymbol = Symbol(\"elmTestSymbol\");\n" + ++ (content + |> Regex.replace testVariantDefinition (\{ match } -> match ++ "__elmTestSymbol: __elmTestSymbol, ") + |> Regex.replaceAtMost 1 + checkDefinition + (\{ submatches } -> + case submatches of + (Just firstSubmatch) :: _ -> + firstSubmatch ++ " = value => value && value.__elmTestSymbol === __elmTestSymbol ? $elm$core$Maybe$Just(value) : $elm$core$Maybe$Nothing;" + + _ -> + crash "addKernelTestChecking: no submatches found" + ) + ) + + +before : String +before = + """// Apply Node polyfills as necessary. +var window = { + Date: Date, + addEventListener: function () {}, + removeEventListener: function () {}, +}; + +var location = { + href: '', + host: '', + hostname: '', + protocol: '', + origin: '', + port: '', + pathname: '', + search: '', + hash: '', + username: '', + password: '', +}; +var document = { body: {}, createTextNode: function () {}, location: location }; + +if (typeof FileList === 'undefined') { + FileList = function () {}; +} + +if (typeof File === 'undefined') { + File = function () {}; +} + +if (typeof XMLHttpRequest === 'undefined') { + XMLHttpRequest = function () { + return { + addEventListener: function () {}, + open: function () {}, + send: function () {}, + }; + }; + + var oldConsoleWarn = console.warn; + console.warn = function () { + if ( + arguments.length === 1 && + arguments[0].indexOf('Compiled in DEV mode') === 0 + ) + return; + return oldConsoleWarn.apply(console, arguments); + }; +} + +if (typeof FormData === 'undefined') { + FormData = function () { + this._data = []; + }; + FormData.prototype.append = function () { + this._data.push(Array.prototype.slice.call(arguments)); + }; +} +""" + + +after : String +after = + """// Run the Elm app. +var app = Elm.Test.Generated.Main.init({ flags: Date.now() }); + +var report = 'console'; + +var nextResultToPrint = null; +var results = new Map(); +var failures = 0; +var todos = []; +var testsToRun = -1; +var startingTime = Date.now(); + +function printResult(result) { + switch (report) { + case 'console': + switch (result.type) { + case 'begin': + console.log(makeWindowsSafe(result.output)); + break; + case 'complete': + switch (result.status) { + case 'pass': + // passed tests should be printed only if they contain distributionReport + if (result.distributionReport !== undefined) { + console.log(makeWindowsSafe(result.distributionReport)); + } + break; + case 'todo': + // todos will be shown in the SUMMARY only. + break; + case 'fail': + console.log(makeWindowsSafe(result.failure)); + break; + default: + throw new Error(`Unexpected result.status: ${result.status}`); + } + break; + case 'summary': + console.log(makeWindowsSafe(result.summary)); + break; + default: + throw new Error(`Unexpected result.type: ${result.type}`); + } + break; + + case 'json': + console.log(JSON.stringify(result)); + break; + + case 'junit': + // JUnit does everything at once in SUMMARY, elsewhere + break; + } +} + +function flushResults() { + // Only print any results if we're ready - that is, nextResultToPrint + // is no longer null. (BEGIN changes it from null to 0.) + if (nextResultToPrint !== null) { + var result = results.get(nextResultToPrint); + + while ( + // If there are no more results to print, then we're done. + nextResultToPrint < testsToRun && + // Otherwise, keep going until we have no result available to print. + typeof result !== 'undefined' + ) { + printResult(result); + nextResultToPrint++; + result = results.get(nextResultToPrint); + } + } +} + +function handleResults(response) { + // TODO print progress bar - e.g. "Running test 5 of 20" on a bar! + // -- yikes, be careful though...test the scenario where test + // authors put Debug.log in their tests - does that mess + // everything up re: the line feed? Seems like it would... + // ...so maybe a bar is not best. Can we do better? Hm. + // Maybe the answer is to print the thing, then Immediately + // backtrack the line feed, so that if someone else does more + // logging, it will overwrite our status update and that's ok? + + Object.keys(response.results).forEach(function (index) { + var result = response.results[index]; + results.set(parseInt(index), result); + + switch (report) { + case 'console': + switch (result.status) { + case 'pass': + // It's a PASS; no need to take any action. + break; + case 'todo': + todos.push(result); + break; + case 'fail': + failures++; + break; + default: + throw new Error(`Unexpected result.status: ${result.status}`); + } + break; + case 'junit': + if (typeof result.failure !== 'undefined') { + failures++; + } + break; + case 'json': + if (result.status === 'fail') { + failures++; + } else if (result.status === 'todo') { + todos.push({ labels: result.labels, todo: result.failures[0] }); + } + break; + } + }); + + flushResults(); +} + +function makeWindowsSafe(text) { + return process.platform === 'win32' ? windowsify(text) : text; +} + +// Fix Windows Unicode problems. Credit to https://github.com/sindresorhus/figures for the Windows compat idea! +var windowsSubstitutions = [ + [/[↓✗►]/g, '>'], + [/╵│╷╹┃╻/g, '|'], + [/═/g, '='], + [/▔/g, '-'], + [/✔/g, '√'], +]; + +function windowsify(str) { + return windowsSubstitutions.reduce(function (result /*: string */, sub) { + return result.replace(sub[0], sub[1]); + }, str); +} + +// Use ports for inter-process communication. +app.ports.elmTestPort__send.subscribe(function (msg) { + var response = JSON.parse(msg); + + switch (response.type) { + case 'FINISHED': + handleResults(response); + + // Print the summmary. + app.ports.elmTestPort__receive.send( + { + type: 'SUMMARY', + duration: Date.now() - startingTime, + failures: failures, + todos: todos, + } + ); + + break; + case 'SUMMARY': + flushResults(); + + if (response.exitCode === 1) { + // The tests could not even run. At the time of this writing, the + // only case is “No exposed values of type Test found”. That + // _could_ have been caught at compile time, but the current + // architecture needs to actually run the JS to figure out which + // exposed values are of type Test. That’s why this type of + // response is handled differently than others. + console.error(response.message); + } else { + printResult(response.message); + + if (report === 'junit') { + var xml = response.message; + var values = Array.from(results.values()); + + xml.testsuite.testcase = xml.testsuite.testcase.concat(values); + + // The XmlBuilder by default does not remove characters that are + // invalid in XML, like backspaces. However, we can pass it an + // `invalidCharReplacement` option to tell it how to handle + // those characters, rather than crashing. In an attempt to + // retain useful information in the output, we try and output a + // hex-encoded unicode codepoint for the invalid character. For + // example, the start of a terminal escape (`\u{001B}` in Elm) will be output as a + // literal `\u{001B}`. + var invalidCharReplacement = function (char) { + return ( + '\\\\u{' + + char.codePointAt(0).toString(16).padStart(4, '0') + + '}' + ); + }; + + console.log( + XmlBuilder.create(xml, { + invalidCharReplacement: invalidCharReplacement, + }).end() + ); + } + } + + // resolve(response.exitCode); + break; + case 'BEGIN': + testsToRun = response.testCount; + + if (!isMachineReadable(report)) { + var headline = 'elm-test """ ++ V.toChars V.elmCompiler ++ """'; + var bar = '-'.repeat(headline.length); + + console.log('\\n' + headline + '\\n' + bar + '\\n'); + } + + printResult(response.message); + + // Now we're ready to print results! + nextResultToPrint = 0; + + flushResults(); + + break; + case 'RESULTS': + handleResults(response); + + break; + case 'ERROR': + throw new Error(response.message); + default: + throw new Error( + 'Unrecognized message from worker:' + response.type + ); + } +}); + +function isMachineReadable(report) { + switch (report) { + case 'json': + case 'junit': + return true; + case 'console': + return false; + } +} + +app.ports.elmTestPort__receive.send({ type: 'TEST', index: -1 });""" + + +testGeneratedMain : + List + { moduleName : String + , possiblyTests : List String + } + -> List String + -> List String + -> Flags + -> Task Never String +testGeneratedMain testModules testFileGlobs testFilePaths (Flags maybeSeed maybeRuns report) = + let + seedIO : Task Never Int + seedIO = + case maybeSeed of + Just seedValue -> + Task.pure seedValue + + Nothing -> + Utils.nodeMathRandom + |> Task.fmap (\seedRandom -> floor (seedRandom * 407199254740991) + 1000) + + imports : List String + imports = + List.map (\mod -> "import " ++ mod.moduleName) testModules + + possiblyTestsList : List String + possiblyTestsList = + List.map makeModuleTuple testModules + in + seedIO + |> Task.fmap + (\seedValue -> + """module Test.Generated.Main exposing (main) + +""" ++ String.join "\n" imports ++ """ + +import Test.Reporter.Reporter exposing (Report(..)) +import Console.Text exposing (UseColor(..)) +import Test.Runner.Node +import Test + +main : Test.Runner.Node.TestProgram +main = + Test.Runner.Node.run + { runs = """ ++ String.fromInt (Maybe.withDefault 100 maybeRuns) ++ """ + , report = """ ++ generateElmReportVariant report ++ """ + , seed = """ ++ String.fromInt seedValue ++ """ + , processes = 1 + , globs = + """ ++ indentAllButFirstLine 12 (List.map (Encode.encode 0 << Encode.string) testFileGlobs) ++ """ + , paths = + """ ++ indentAllButFirstLine 12 (List.map (Encode.encode 0 << Encode.string) testFilePaths) ++ """ + } + """ ++ indentAllButFirstLine 8 possiblyTestsList + ) + + +indentAllButFirstLine : Int -> List String -> String +indentAllButFirstLine indent list = + case list of + [] -> + "[]" + + head :: rest -> + "[ " + ++ head + ++ String.concat (List.map (\entry -> "\n" ++ String.repeat indent " " ++ ", " ++ entry) rest) + ++ "\n" + ++ String.repeat indent " " + ++ "]" + + +makeModuleTuple : { moduleName : String, possiblyTests : List String } -> String +makeModuleTuple mod = + let + list : List String + list = + List.map (\test -> "Test.Runner.Node.check " ++ mod.moduleName ++ "." ++ test) + mod.possiblyTests + in + "( \"" + ++ mod.moduleName + ++ "\"\n" + ++ String.repeat 10 " " + ++ ", " + ++ indentAllButFirstLine 12 list + ++ "\n" + ++ String.repeat 10 " " + ++ ")" + + +generateElmReportVariant : Maybe Report -> String +generateElmReportVariant maybeReport = + case maybeReport of + Just Json -> + "JsonReport" + + Just JUnit -> + "JUnitReport" + + _ -> + "ConsoleReport UseColor" + + + +-- GET INFORMATION + + +style : Reporting.Style +style = + Reporting.silent + + +extractExposedPossiblyTests : String -> Task Never (Maybe ( String, List String )) +extractExposedPossiblyTests path = + File.readUtf8 path + |> Task.bind + (\bytes -> + case Parse.fromByteString (SV.fileSyntaxVersion path) Parse.Application bytes of + Ok (Src.Module _ (Just (A.At _ name)) (A.At _ exposing_) _ _ _ _ _ _ _) -> + let + exposed : List Name + exposed = + case exposing_ of + Src.Open _ _ -> + [] + + Src.Explicit (A.At _ exposedList) -> + List.filterMap + (\( _, exposedValue ) -> + case exposedValue of + Src.Lower (A.At _ lowerName) -> + Just lowerName + + Src.Upper _ _ -> + Nothing + + Src.Operator _ _ -> + Nothing + ) + exposedList + in + Task.pure (Just ( name, exposed )) + + _ -> + Task.pure Nothing + ) + + + +-- COMMAND LINE + + +type FileType + = IsFile + | IsDirectory + | DoesNotExist + + +stat : FilePath -> Task Never FileType +stat path = + Utils.dirDoesFileExist path + |> Task.bind + (\isFile -> + Utils.dirDoesDirectoryExist path + |> Task.fmap + (\isDirectory -> + case ( isFile, isDirectory ) of + ( True, _ ) -> + IsFile + + ( _, True ) -> + IsDirectory + + ( False, False ) -> + DoesNotExist + ) + ) + + + +-- RESOLVE FILES + + +type Error + = FileDoesNotExist FilePath + | NoElmFiles FilePath + + +resolveFile : FilePath -> Task Never (Result Error (List FilePath)) +resolveFile path = + stat path + |> Task.bind + (\fileType -> + case fileType of + IsFile -> + Task.pure (Ok [ path ]) + + IsDirectory -> + findAllGuidaAndElmFiles path + |> Task.fmap + (\elmFiles -> + case elmFiles of + [] -> + Err (NoElmFiles path) + + _ -> + Ok elmFiles + ) + + DoesNotExist -> + Task.pure (Err (FileDoesNotExist path)) + ) + + +resolveElmFiles : List FilePath -> Task Never (Result (List Error) (List FilePath)) +resolveElmFiles inputFiles = + Task.mapM resolveFile inputFiles + |> Task.fmap collectErrors + |> Task.fmap + (\result -> + case result of + Err ls -> + Err ls + + Ok files -> + Ok (List.concat files) + ) + + +collectErrors : List (Result e v) -> Result (List e) (List v) +collectErrors = + List.foldl + (\next acc -> + case ( next, acc ) of + ( Err e, Ok _ ) -> + Err [ e ] + + ( Err e, Err es ) -> + Err (e :: es) + + ( Ok v, Ok vs ) -> + Ok (v :: vs) + + ( Ok _, Err es ) -> + Err es + ) + (Ok []) + + + +-- FILESYSTEM + + +collectFiles : (a -> Task Never (List a)) -> a -> Task Never (List a) +collectFiles children root = + children root + |> Task.bind (\xs -> Task.mapM (collectFiles children) xs) + |> Task.fmap (\subChildren -> root :: List.concat subChildren) + + +listDir : FilePath -> Task Never (List FilePath) +listDir path = + Utils.dirListDirectory path + |> Task.fmap (List.map (\file -> path ++ "/" ++ file)) + + +fileList : FilePath -> Task Never (List FilePath) +fileList = + let + children : FilePath -> Task Never (List FilePath) + children path = + if isSkippable path then + Task.pure [] + + else + Utils.dirDoesDirectoryExist path + |> Task.bind + (\directory -> + if directory then + listDir path + + else + Task.pure [] + ) + in + collectFiles children + + +isSkippable : FilePath -> Bool +isSkippable path = + List.any identity + [ hasFilename "elm-stuff" path + , hasFilename "node_modules" path + , hasFilename ".git" path + ] + + +hasExtension : String -> FilePath -> Bool +hasExtension ext path = + ext == Utils.fpTakeExtension path + + +findAllGuidaAndElmFiles : FilePath -> Task Never (List FilePath) +findAllGuidaAndElmFiles inputFile = + fileList inputFile + |> Task.fmap (List.filter (\path -> hasExtension ".guida" path || hasExtension ".elm" path)) + + +hasFilename : String -> FilePath -> Bool +hasFilename name path = + name == Utils.fpTakeFileName path + + +{-| FROM INSTALL +-} + + + +-- ATTEMPT CHANGES + + +attemptChanges : FilePath -> Solver.Env -> Outline.AppOutline -> Task Exit.Test () +attemptChanges root env appOutline = + Task.eio Exit.TestBadDetails <| + BW.withScope + (\scope -> + let + newOutline : Outline.Outline + newOutline = + Outline.App appOutline + in + Outline.write (Stuff.testDir root) newOutline + |> Task.bind (\_ -> Details.verifyInstall scope root env newOutline) + ) + + + +-- MAKE APP PLAN + + +makeAppPlan : Solver.Env -> Pkg.Name -> Outline.AppOutline -> Task Exit.Test Outline.AppOutline +makeAppPlan (Solver.Env cache _ connection registry) pkg ((Outline.AppOutline elmVersion sourceDirs direct indirect testDirect testIndirect) as outline) = + if Dict.member identity pkg direct then + Task.pure outline + + else + -- is it already indirect? + case Dict.get identity pkg indirect of + Just vsn -> + Task.pure <| + Outline.AppOutline elmVersion + sourceDirs + (Dict.insert identity pkg vsn direct) + (Dict.remove identity pkg indirect) + testDirect + testIndirect + + Nothing -> + -- is it already a test dependency? + case Dict.get identity pkg testDirect of + Just vsn -> + Task.pure <| + Outline.AppOutline elmVersion + sourceDirs + (Dict.insert identity pkg vsn direct) + indirect + (Dict.remove identity pkg testDirect) + testIndirect + + Nothing -> + -- is it already an indirect test dependency? + case Dict.get identity pkg testIndirect of + Just vsn -> + Task.pure <| + Outline.AppOutline elmVersion + sourceDirs + (Dict.insert identity pkg vsn direct) + indirect + testDirect + (Dict.remove identity pkg testIndirect) + + Nothing -> + -- finally try to add it from scratch + case Registry.getVersions_ pkg registry of + Err suggestions -> + case connection of + Solver.Online _ -> + Task.throw (Exit.TestUnknownPackageOnline pkg suggestions) + + Solver.Offline -> + Task.throw (Exit.TestUnknownPackageOffline pkg suggestions) + + Ok _ -> + Task.io (Solver.addToApp cache connection registry pkg outline False) + |> Task.bind + (\result -> + case result of + Solver.SolverOk (Solver.AppSolution _ _ app) -> + Task.pure app + + Solver.NoSolution -> + Task.throw (Exit.TestNoOnlineAppSolution pkg) + + Solver.NoOfflineSolution -> + Task.throw (Exit.TestNoOfflineAppSolution pkg) + + Solver.SolverErr exit -> + Task.throw (Exit.TestHadSolverTrouble exit) + ) + + + +-- MAKE PACKAGE PLAN + + +makePkgPlan : Solver.Env -> Dict ( String, String ) Pkg.Name C.Constraint -> Outline.AppOutline -> Task Exit.Test Outline.AppOutline +makePkgPlan env cons outline = + makePkgPlanHelp env (Dict.toList Pkg.compareName cons) outline + + +makePkgPlanHelp : Solver.Env -> List ( Pkg.Name, C.Constraint ) -> Outline.AppOutline -> Task Exit.Test Outline.AppOutline +makePkgPlanHelp ((Solver.Env cache _ connection registry) as env) cons outline = + case cons of + [] -> + Task.pure outline + + ( pkg, con ) :: remainingCons -> + Task.io (Solver.addToTestApp cache connection registry pkg con outline) + |> Task.bind + (\result -> + case result of + Solver.SolverOk (Solver.AppSolution _ _ app) -> + makePkgPlanHelp env remainingCons app + + Solver.NoSolution -> + Task.throw (Exit.TestNoOnlinePkgSolution pkg) + + Solver.NoOfflineSolution -> + Task.throw (Exit.TestNoOfflinePkgSolution pkg) + + Solver.SolverErr exit -> + Task.throw (Exit.TestHadSolverTrouble exit) + ) + + + +-- GET INTERPRETER + + +getInterpreter : Task Never FilePath +getInterpreter = + getInterpreterHelp "node` or `nodejs" <| + (Utils.dirFindExecutable "node" + |> Task.bind + (\exe1 -> + Utils.dirFindExecutable "nodejs" + |> Task.fmap (\exe2 -> Maybe.or exe1 exe2) + ) + ) + + +getInterpreterHelp : String -> Task Never (Maybe FilePath) -> Task Never FilePath +getInterpreterHelp name findExe = + findExe + |> Task.bind + (\maybePath -> + case maybePath of + Just path -> + Task.pure path + + Nothing -> + IO.hPutStrLn IO.stderr (exeNotFound name) + |> Task.bind (\_ -> Exit.exitFailure) + ) + + +exeNotFound : String -> String +exeNotFound name = + "The TEST relies on node.js to execute JavaScript code outside the browser.\n" + ++ "I could not find executable `" + ++ name + ++ "` on your PATH though!\n\n" + ++ "You can install node.js from . If it is already installed\n" + ++ "but has a different name, use the --interpreter flag." + + +{-| FROM MAKE +-} +runMake : String -> String -> Task Never (Result Exit.Test String) +runMake root path = + BW.withScope + (\scope -> + Task.run <| + (Task.eio Exit.TestBadDetails (Details.load style scope root) + |> Task.bind + (\details -> + buildPaths root details (NE.Nonempty path []) + |> Task.bind + (\artifacts -> + toBuilder 0 root details artifacts + ) + ) + ) + ) + + +buildPaths : FilePath -> Details.Details -> NE.Nonempty FilePath -> Task Exit.Test Build.Artifacts +buildPaths root details paths = + Task.eio Exit.TestCannotBuild <| + Build.fromPaths style root details paths + + + +-- TO BUILDER + + +toBuilder : Int -> FilePath -> Details.Details -> Build.Artifacts -> Task Exit.Test String +toBuilder leadingLines root details artifacts = + Task.mapError Exit.TestBadGenerate <| + Generate.dev False leadingLines root details artifacts + + + +-- PARSERS + + +type Report + = Json + | JUnit + | Console + + +format : Parser +format = + Parser + { singular = "format" + , plural = "formats" + , suggest = \_ -> Task.pure [] + , examples = \_ -> Task.pure [ "json", "junit", "console" ] + } + + +parseReport : String -> Maybe Report +parseReport report = + case report of + "json" -> + Just Json + + "junit" -> + Just JUnit + + "console" -> + Just Console + + _ -> + Nothing diff --git a/src/Terminal/Uninstall.elm b/src/Terminal/Uninstall.elm new file mode 100644 index 0000000000..66b4ab66d3 --- /dev/null +++ b/src/Terminal/Uninstall.elm @@ -0,0 +1,360 @@ +module Terminal.Uninstall exposing + ( Args(..) + , Flags(..) + , run + ) + +import Builder.BackgroundWriter as BW +import Builder.Deps.Solver as Solver +import Builder.Elm.Details as Details +import Builder.Elm.Outline as Outline +import Builder.Reporting as Reporting +import Builder.Reporting.Exit as Exit +import Builder.Stuff as Stuff +import Compiler.Elm.Constraint as C +import Compiler.Elm.Package as Pkg +import Compiler.Elm.Version as V +import Compiler.Reporting.Doc as D +import Data.Map as Dict exposing (Dict) +import System.IO as IO +import Task exposing (Task) +import Utils.Main exposing (FilePath) +import Utils.Task.Extra as Task + + + +-- RUN + + +type Args + = NoArgs + | Uninstall Pkg.Name + + +type Flags + = Flags Bool + + +run : Args -> Flags -> Task Never () +run args (Flags autoYes) = + Reporting.attempt Exit.uninstallToReport + (Stuff.findRoot + |> Task.bind + (\maybeRoot -> + case maybeRoot of + Nothing -> + Task.pure (Err Exit.UninstallNoOutline) + + Just root -> + case args of + NoArgs -> + Task.pure (Err Exit.UninstallNoArgs) + + Uninstall pkg -> + Task.run + (Task.eio Exit.UninstallBadRegistry Solver.initEnv + |> Task.bind + (\env -> + Task.eio Exit.UninstallBadOutline (Outline.read root) + |> Task.bind + (\oldOutline -> + case oldOutline of + Outline.App outline -> + makeAppPlan env pkg outline + |> Task.bind (\changes -> attemptChanges root env oldOutline V.toChars changes autoYes) + + Outline.Pkg outline -> + makePkgPlan pkg outline + |> Task.bind (\changes -> attemptChanges root env oldOutline C.toChars changes autoYes) + ) + ) + ) + ) + ) + + + +-- ATTEMPT CHANGES + + +type Changes vsn + = AlreadyNotPresent + | Changes (Dict ( String, String ) Pkg.Name (Change vsn)) Outline.Outline + + +attemptChanges : String -> Solver.Env -> Outline.Outline -> (a -> String) -> Changes a -> Bool -> Task Exit.Uninstall () +attemptChanges root env oldOutline toChars changes autoYes = + case changes of + AlreadyNotPresent -> + Task.io (IO.putStrLn "It is not currently installed!") + + Changes changeDict newOutline -> + let + widths : Widths + widths = + Dict.foldr compare (widen toChars) (Widths 0 0 0) changeDict + + changeDocs : ChangeDocs + changeDocs = + Dict.foldr compare (addChange toChars widths) (Docs [] [] []) changeDict + in + attemptChangesHelp root env oldOutline newOutline autoYes <| + D.vcat + [ D.fromChars "Here is my plan:" + , viewChangeDocs changeDocs + , D.fromChars "" + , D.fromChars "Would you like me to update your elm.json accordingly? [Y/n]: " + ] + + +attemptChangesHelp : FilePath -> Solver.Env -> Outline.Outline -> Outline.Outline -> Bool -> D.Doc -> Task Exit.Uninstall () +attemptChangesHelp root env oldOutline newOutline autoYes question = + Task.eio Exit.UninstallBadDetails <| + BW.withScope + (\scope -> + let + askQuestion : Task Never Bool + askQuestion = + if autoYes then + Task.pure True + + else + Reporting.ask question + in + askQuestion + |> Task.bind + (\approved -> + if approved then + Outline.write root newOutline + |> Task.bind (\_ -> Details.verifyInstall scope root env newOutline) + |> Task.bind + (\result -> + case result of + Err exit -> + Outline.write root oldOutline + |> Task.fmap (\_ -> Err exit) + + Ok () -> + IO.putStrLn "Success!" + |> Task.fmap (\_ -> Ok ()) + ) + + else + IO.putStrLn "Okay, I did not change anything!" + |> Task.fmap (\_ -> Ok ()) + ) + ) + + + +-- MAKE APP PLAN + + +makeAppPlan : Solver.Env -> Pkg.Name -> Outline.AppOutline -> Task Exit.Uninstall (Changes V.Version) +makeAppPlan (Solver.Env cache _ connection registry) pkg ((Outline.AppOutline _ _ direct _ testDirect _) as outline) = + case Dict.get identity pkg (Dict.union direct testDirect) of + Just _ -> + Task.io (Solver.removeFromApp cache connection registry pkg outline) + |> Task.bind + (\result -> + case result of + Solver.SolverOk (Solver.AppSolution old new app) -> + Task.pure (Changes (detectChanges old new) (Outline.App app)) + + Solver.NoSolution -> + Task.throw (Exit.UninstallNoOnlineAppSolution pkg) + + Solver.NoOfflineSolution -> + Task.throw (Exit.UninstallNoOfflineAppSolution pkg) + + Solver.SolverErr exit -> + Task.throw (Exit.UninstallHadSolverTrouble exit) + ) + + Nothing -> + Task.pure AlreadyNotPresent + + + +-- MAKE PACKAGE PLAN + + +makePkgPlan : Pkg.Name -> Outline.PkgOutline -> Task Exit.Uninstall (Changes C.Constraint) +makePkgPlan pkg (Outline.PkgOutline name summary license version exposed deps test elmVersion) = + let + old : Dict ( String, String ) Pkg.Name C.Constraint + old = + Dict.union deps test + in + if Dict.member identity pkg old then + let + new : Dict ( String, String ) Pkg.Name C.Constraint + new = + Dict.remove identity pkg old + + changes : Dict ( String, String ) Pkg.Name (Change C.Constraint) + changes = + detectChanges old new + in + Task.pure <| + Changes changes <| + Outline.Pkg <| + Outline.PkgOutline name + summary + license + version + exposed + (Dict.remove identity pkg deps) + (Dict.remove identity pkg test) + elmVersion + + else + Task.pure AlreadyNotPresent + + + +-- CHANGES + + +type Change a + = Insert a + | Change a a + | Remove a + + +detectChanges : Dict ( String, String ) Pkg.Name a -> Dict ( String, String ) Pkg.Name a -> Dict ( String, String ) Pkg.Name (Change a) +detectChanges old new = + Dict.merge compare + (\k v -> Dict.insert identity k (Remove v)) + (\k oldElem newElem acc -> + case keepChange k oldElem newElem of + Just change -> + Dict.insert identity k change acc + + Nothing -> + acc + ) + (\k v -> Dict.insert identity k (Insert v)) + old + new + Dict.empty + + +keepChange : k -> v -> v -> Maybe (Change v) +keepChange _ old new = + if old == new then + Nothing + + else + Just (Change old new) + + + +-- VIEW CHANGE DOCS + + +type ChangeDocs + = Docs (List D.Doc) (List D.Doc) (List D.Doc) + + +viewChangeDocs : ChangeDocs -> D.Doc +viewChangeDocs (Docs inserts changes removes) = + D.indent 2 <| + D.vcat <| + List.concat <| + [ viewNonZero "Add:" inserts + , viewNonZero "Change:" changes + , viewNonZero "Remove:" removes + ] + + +viewNonZero : String -> List D.Doc -> List D.Doc +viewNonZero title entries = + if List.isEmpty entries then + [] + + else + [ D.fromChars "" + , D.fromChars title + , D.indent 2 (D.vcat entries) + ] + + + +-- VIEW CHANGE + + +addChange : (a -> String) -> Widths -> Pkg.Name -> Change a -> ChangeDocs -> ChangeDocs +addChange toChars widths name change (Docs inserts changes removes) = + case change of + Insert new -> + Docs (viewInsert toChars widths name new :: inserts) changes removes + + Change old new -> + Docs inserts (viewChange toChars widths name old new :: changes) removes + + Remove old -> + Docs inserts changes (viewRemove toChars widths name old :: removes) + + +viewInsert : (a -> String) -> Widths -> Pkg.Name -> a -> D.Doc +viewInsert toChars (Widths nameWidth leftWidth _) name new = + viewName nameWidth name + |> D.plus (pad leftWidth (toChars new)) + + +viewChange : (a -> String) -> Widths -> Pkg.Name -> a -> a -> D.Doc +viewChange toChars (Widths nameWidth leftWidth rightWidth) name old new = + D.hsep + [ viewName nameWidth name + , pad leftWidth (toChars old) + , D.fromChars "=>" + , pad rightWidth (toChars new) + ] + + +viewRemove : (a -> String) -> Widths -> Pkg.Name -> a -> D.Doc +viewRemove toChars (Widths nameWidth leftWidth _) name old = + viewName nameWidth name + |> D.plus (pad leftWidth (toChars old)) + + +viewName : Int -> Pkg.Name -> D.Doc +viewName width name = + D.fill (width + 3) (D.fromPackage name) + + +pad : Int -> String -> D.Doc +pad width string = + D.fromChars (String.repeat (width - String.length string) " ") + |> D.a (D.fromChars string) + + + +-- WIDTHS + + +type Widths + = Widths Int Int Int + + +widen : (a -> String) -> Pkg.Name -> Change a -> Widths -> Widths +widen toChars pkg change (Widths name left right) = + let + toLength : a -> Int + toLength a = + String.length (toChars a) + + newName : Int + newName = + max name (String.length (Pkg.toChars pkg)) + in + case change of + Insert new -> + Widths newName (max left (toLength new)) right + + Change old new -> + Widths newName (max left (toLength old)) (max right (toLength new)) + + Remove old -> + Widths newName (max left (toLength old)) right diff --git a/src/Text/PrettyPrint/ANSI/Leijen.elm b/src/Text/PrettyPrint/ANSI/Leijen.elm new file mode 100644 index 0000000000..824799ff98 --- /dev/null +++ b/src/Text/PrettyPrint/ANSI/Leijen.elm @@ -0,0 +1,441 @@ +module Text.PrettyPrint.ANSI.Leijen exposing + ( Color(..) + , Doc + , SimpleDoc(..) + , Style + , a + , align + , append + , black + , blue + , cat + , cyan + , displayIO + , displayS + , dullcyan + , dullred + , dullyellow + , empty + , fill + , fillSep + , green + , hang + , hcat + , hsep + , indent + , magenta + , plain + , plus + , red + , renderPretty + , sep + , text + , underline + , vcat + , yellow + ) + +import Pretty as P +import Pretty.Renderer as PR +import System.Console.Ansi as Ansi +import System.IO as IO +import Task exposing (Task) + + +type alias Doc = + P.Doc Style + + +type SimpleDoc + = SEmpty + | SText String SimpleDoc + | SLine Int SimpleDoc + | SSGR (List Ansi.SGR) SimpleDoc + + +displayIO : IO.Handle -> SimpleDoc -> Task Never () +displayIO handle simpleDoc = + IO.hPutStr handle (displayS simpleDoc "") + + +renderPretty : Float -> Int -> Doc -> SimpleDoc +renderPretty _ w doc = + PR.pretty w + { init = { styled = False, newline = False, list = [] } + , tagged = + \style str acc -> + { acc | styled = True, list = SText str :: SSGR (styleToSgrs style) :: acc.list } + , untagged = + \str acc -> + let + newAcc : { styled : Bool, newline : Bool, list : List (SimpleDoc -> SimpleDoc) } + newAcc = + if acc.styled then + { acc | styled = False, list = SSGR [ Ansi.Reset ] :: acc.list } + + else + acc + in + if newAcc.newline then + { newAcc | newline = False, list = SLine (String.length str) :: newAcc.list } + + else + { newAcc | list = SText str :: newAcc.list } + , newline = \acc -> { acc | newline = True } + , outer = \{ list } -> List.foldl (<|) SEmpty list + } + doc + + +styleToSgrs : Style -> List Ansi.SGR +styleToSgrs style = + [ if style.bold then + Just (Ansi.SetConsoleIntensity Ansi.BoldIntensity) + + else + Nothing + , if style.underline then + Just (Ansi.SetUnderlining Ansi.SingleUnderline) + + else + Nothing + , style.color + |> Maybe.map + (\color -> + case color of + Red -> + Ansi.SetColor Ansi.Foreground Ansi.Vivid Ansi.Red + + Green -> + Ansi.SetColor Ansi.Foreground Ansi.Vivid Ansi.Green + + Cyan -> + Ansi.SetColor Ansi.Foreground Ansi.Vivid Ansi.Cyan + + Magenta -> + Ansi.SetColor Ansi.Foreground Ansi.Vivid Ansi.Magenta + + Blue -> + Ansi.SetColor Ansi.Foreground Ansi.Vivid Ansi.Blue + + Black -> + Ansi.SetColor Ansi.Foreground Ansi.Vivid Ansi.Black + + Yellow -> + Ansi.SetColor Ansi.Foreground Ansi.Vivid Ansi.Yellow + + DullCyan -> + Ansi.SetColor Ansi.Foreground Ansi.Dull Ansi.Cyan + + DullRed -> + Ansi.SetColor Ansi.Foreground Ansi.Dull Ansi.Red + + DullYellow -> + Ansi.SetColor Ansi.Foreground Ansi.Dull Ansi.Yellow + ) + ] + |> List.filterMap identity + + +displayS : SimpleDoc -> String -> String +displayS simpleDoc acc = + case simpleDoc of + SEmpty -> + acc + + SText str sd -> + displayS sd (acc ++ str) + + SLine n sd -> + displayS sd (acc ++ "\n" ++ String.repeat n " ") + + SSGR (Ansi.Reset :: tail) sd -> + displayS (SSGR tail sd) (acc ++ "\u{001B}[0m") + + SSGR ((Ansi.SetUnderlining Ansi.SingleUnderline) :: tail) sd -> + displayS (SSGR tail sd) (acc ++ "\u{001B}[4m") + + SSGR ((Ansi.SetColor _ Ansi.Dull Ansi.Red) :: tail) sd -> + displayS (SSGR tail sd) (acc ++ "\u{001B}[31m") + + SSGR ((Ansi.SetColor _ Ansi.Vivid Ansi.Red) :: tail) sd -> + displayS (SSGR tail sd) (acc ++ "\u{001B}[91m") + + SSGR ((Ansi.SetColor _ Ansi.Dull Ansi.Green) :: tail) sd -> + displayS (SSGR tail sd) (acc ++ "\u{001B}[32m") + + SSGR ((Ansi.SetColor _ Ansi.Vivid Ansi.Green) :: tail) sd -> + displayS (SSGR tail sd) (acc ++ "\u{001B}[92m") + + SSGR ((Ansi.SetColor _ Ansi.Dull Ansi.Yellow) :: tail) sd -> + displayS (SSGR tail sd) (acc ++ "\u{001B}[33m") + + SSGR ((Ansi.SetColor _ Ansi.Vivid Ansi.Yellow) :: tail) sd -> + displayS (SSGR tail sd) (acc ++ "\u{001B}[93m") + + SSGR ((Ansi.SetColor _ Ansi.Dull Ansi.Cyan) :: tail) sd -> + displayS (SSGR tail sd) (acc ++ "\u{001B}[36m") + + SSGR ((Ansi.SetColor _ Ansi.Vivid Ansi.Cyan) :: tail) sd -> + displayS (SSGR tail sd) (acc ++ "\u{001B}[96m") + + SSGR ((Ansi.SetUnderlining Ansi.DoubleUnderline) :: tail) sd -> + displayS (SSGR tail sd) (acc ++ "\u{001B}[4:2m") + + SSGR ((Ansi.SetUnderlining Ansi.NoUnderline) :: tail) sd -> + displayS (SSGR tail sd) (acc ++ "\u{001B}[24m") + + SSGR ((Ansi.SetColor _ Ansi.Dull Ansi.Black) :: tail) sd -> + displayS (SSGR tail sd) (acc ++ "\u{001B}[30m") + + SSGR ((Ansi.SetColor _ Ansi.Dull Ansi.Blue) :: tail) sd -> + displayS (SSGR tail sd) (acc ++ "\u{001B}[34m") + + SSGR ((Ansi.SetColor _ Ansi.Dull Ansi.Magenta) :: tail) sd -> + displayS (SSGR tail sd) (acc ++ "\u{001B}[35m") + + SSGR ((Ansi.SetColor _ Ansi.Dull Ansi.White) :: tail) sd -> + displayS (SSGR tail sd) (acc ++ "\u{001B}[37m") + + SSGR ((Ansi.SetColor _ Ansi.Vivid Ansi.Black) :: tail) sd -> + displayS (SSGR tail sd) (acc ++ "\u{001B}[90m") + + SSGR ((Ansi.SetColor _ Ansi.Vivid Ansi.Blue) :: tail) sd -> + displayS (SSGR tail sd) (acc ++ "\u{001B}[94m") + + SSGR ((Ansi.SetColor _ Ansi.Vivid Ansi.Magenta) :: tail) sd -> + displayS (SSGR tail sd) (acc ++ "\u{001B}[95m") + + SSGR ((Ansi.SetColor _ Ansi.Vivid Ansi.White) :: tail) sd -> + displayS (SSGR tail sd) (acc ++ "\u{001B}[97m") + + SSGR ((Ansi.SetConsoleIntensity Ansi.BoldIntensity) :: tail) sd -> + displayS (SSGR tail sd) (acc ++ "\u{001B}[1m") + + SSGR ((Ansi.SetConsoleIntensity Ansi.FaintIntensity) :: tail) sd -> + displayS (SSGR tail sd) (acc ++ "\u{001B}[2m") + + SSGR ((Ansi.SetConsoleIntensity Ansi.NormalIntensity) :: tail) sd -> + displayS (SSGR tail sd) (acc ++ "\u{001B}[22m") + + SSGR ((Ansi.SetItalicized True) :: tail) sd -> + displayS (SSGR tail sd) (acc ++ "\u{001B}[3m") + + SSGR ((Ansi.SetItalicized False) :: tail) sd -> + displayS (SSGR tail sd) (acc ++ "\u{001B}[23m") + + SSGR ((Ansi.SetBlinkSpeed Ansi.SlowBlink) :: tail) sd -> + displayS (SSGR tail sd) (acc ++ "\u{001B}[5m") + + SSGR ((Ansi.SetBlinkSpeed Ansi.RapidBlink) :: tail) sd -> + displayS (SSGR tail sd) (acc ++ "\u{001B}[6m") + + SSGR ((Ansi.SetBlinkSpeed Ansi.NoBlink) :: tail) sd -> + displayS (SSGR tail sd) (acc ++ "\u{001B}[25m") + + SSGR ((Ansi.SetVisible True) :: tail) sd -> + displayS (SSGR tail sd) (acc ++ "\u{001B}[28m") + + SSGR ((Ansi.SetVisible False) :: tail) sd -> + displayS (SSGR tail sd) (acc ++ "\u{001B}[8m") + + SSGR ((Ansi.SetSwapForegroundBackground True) :: tail) sd -> + displayS (SSGR tail sd) (acc ++ "\u{001B}[7m") + + SSGR ((Ansi.SetSwapForegroundBackground False) :: tail) sd -> + displayS (SSGR tail sd) (acc ++ "\u{001B}[27m") + + SSGR [] sd -> + displayS sd acc + + +text : String -> Doc +text = + P.string + + +plain : Doc -> Doc +plain = + updateStyle (\_ -> defaultStyle) + + +underline : Doc -> Doc +underline = + updateStyle (\style -> { style | underline = True }) + + +a : Doc -> Doc -> Doc +a = + P.a + + +plus : Doc -> Doc -> Doc +plus doc2 doc1 = + P.words [ doc1, doc2 ] + + +append : Doc -> Doc -> Doc +append = + P.append + + +align : Doc -> Doc +align = + P.align + + +cat : List Doc -> Doc +cat = + P.group << vcat + + +empty : Doc +empty = + P.empty + + +fill : Int -> Doc -> Doc +fill = + P.indent + + +fillSep : List Doc -> Doc +fillSep = + P.softlines + + +hang : Int -> Doc -> Doc +hang = + P.hang + + +hcat : List Doc -> Doc +hcat docs = + hcatHelp docs empty + + +hcatHelp : List Doc -> Doc -> Doc +hcatHelp docs acc = + case docs of + [] -> + acc + + [ doc ] -> + doc + + doc :: ds -> + hcatHelp ds (P.append doc acc) + + +hsep : List Doc -> Doc +hsep = + P.words + + +indent : Int -> Doc -> Doc +indent = + P.indent + + +sep : List Doc -> Doc +sep = + P.group << P.lines + + +vcat : List Doc -> Doc +vcat = + P.join P.tightline + + +red : Doc -> Doc +red = + updateColor Red + + +cyan : Doc -> Doc +cyan = + updateColor Cyan + + +magenta : Doc -> Doc +magenta = + updateColor Magenta + + +green : Doc -> Doc +green = + updateColor Green + + +blue : Doc -> Doc +blue = + updateColor Blue + + +black : Doc -> Doc +black = + updateColor Black + + +yellow : Doc -> Doc +yellow = + updateColor Yellow + + +dullred : Doc -> Doc +dullred = + updateColor DullRed + + +dullcyan : Doc -> Doc +dullcyan = + updateColor DullCyan + + +dullyellow : Doc -> Doc +dullyellow = + updateColor DullYellow + + + +-- STYLE + + +type alias Style = + { bold : Bool + , underline : Bool + , color : Maybe Color + } + + +type Color + = Red + | Green + | Cyan + | Magenta + | Blue + | Black + | Yellow + | DullCyan + | DullRed + | DullYellow + + +defaultStyle : Style +defaultStyle = + Style False False Nothing + + +updateColor : Color -> Doc -> Doc +updateColor newColor = + updateStyle (\style -> { style | color = Just newColor }) + + +updateStyle : (Style -> Style) -> Doc -> Doc +updateStyle mapper = + P.updateTag + (\_ -> + Maybe.map mapper + >> Maybe.withDefault (mapper defaultStyle) + >> Just + ) diff --git a/src/Utils/Bytes/Decode.elm b/src/Utils/Bytes/Decode.elm new file mode 100644 index 0000000000..fb2de13de3 --- /dev/null +++ b/src/Utils/Bytes/Decode.elm @@ -0,0 +1,273 @@ +module Utils.Bytes.Decode exposing + ( Decoder + , andThen + , assocListDict + , bool + , decode + , everySet + , fail + , float + , int + , jsonPair + , lazy + , list + , map + , map2 + , map3 + , map4 + , map5 + , map6 + , map7 + , map8 + , maybe + , nonempty + , oneOrMore + , result + , string + , succeed + , unit + , unsignedInt8 + ) + +import Bytes +import Bytes.Decode as BD +import Compiler.Data.NonEmptyList as NE +import Compiler.Data.OneOrMore as OneOrMore exposing (OneOrMore) +import Data.Map as Dict exposing (Dict) +import Data.Set as EverySet exposing (EverySet) + + +endian : Bytes.Endianness +endian = + Bytes.BE + + +type alias Decoder a = + BD.Decoder a + + +unsignedInt8 : Decoder Int +unsignedInt8 = + BD.unsignedInt8 + + +decode : Decoder a -> Bytes.Bytes -> Maybe a +decode = + BD.decode + + +andThen : (a -> Decoder b) -> Decoder a -> Decoder b +andThen = + BD.andThen + + +string : Decoder String +string = + BD.unsignedInt32 endian + |> BD.andThen BD.string + + +unit : Decoder () +unit = + BD.unsignedInt8 + |> andThen + (\idx -> + case idx of + 0 -> + BD.succeed () + + _ -> + BD.fail + ) + + +int : Decoder Int +int = + BD.float64 endian |> BD.map round + + +float : Decoder Float +float = + BD.float64 endian + + +bool : Decoder Bool +bool = + BD.map ((==) 1) unsignedInt8 + + +list : Decoder a -> Decoder (List a) +list decoder = + BD.unsignedInt32 endian + |> andThen (\len -> BD.loop ( len, [] ) (listStep decoder)) + + +listStep : Decoder a -> ( Int, List a ) -> Decoder (BD.Step ( Int, List a ) (List a)) +listStep decoder ( n, xs ) = + if n <= 0 then + succeed (BD.Done (List.reverse xs)) + + else + map (\x -> BD.Loop ( n - 1, x :: xs )) decoder + + +succeed : a -> Decoder a +succeed = + BD.succeed + + +fail : Decoder a +fail = + BD.fail + + +maybe : Decoder a -> Decoder (Maybe a) +maybe decoder = + unsignedInt8 + |> andThen + (\n -> + if n == 0 then + succeed Nothing + + else + map Just decoder + ) + + +result : Decoder x -> Decoder a -> Decoder (Result x a) +result errDecoder successDecoder = + BD.unsignedInt8 + |> andThen + (\idx -> + case idx of + 0 -> + BD.map Ok successDecoder + + 1 -> + BD.map Err errDecoder + + _ -> + BD.fail + ) + + +map : (a -> b) -> Decoder a -> Decoder b +map = + BD.map + + +map2 : (a -> b -> result) -> Decoder a -> Decoder b -> Decoder result +map2 = + BD.map2 + + +map3 : (a -> b -> c -> result) -> Decoder a -> Decoder b -> Decoder c -> Decoder result +map3 = + BD.map3 + + +map4 : (a -> b -> c -> d -> result) -> Decoder a -> Decoder b -> Decoder c -> Decoder d -> Decoder result +map4 = + BD.map4 + + +map5 : (a -> b -> c -> d -> e -> result) -> Decoder a -> Decoder b -> Decoder c -> Decoder d -> Decoder e -> Decoder result +map5 = + BD.map5 + + +map6 : (a -> b -> c -> d -> e -> f -> result) -> Decoder a -> Decoder b -> Decoder c -> Decoder d -> Decoder e -> Decoder f -> Decoder result +map6 func decodeA decodeB decodeC decodeD decodeE decodeF = + map5 (\a b c d ( e, f ) -> func a b c d e f) + decodeA + decodeB + decodeC + decodeD + (BD.map2 Tuple.pair + decodeE + decodeF + ) + + +map7 : (a -> b -> c -> d -> e -> f -> g -> result) -> Decoder a -> Decoder b -> Decoder c -> Decoder d -> Decoder e -> Decoder f -> Decoder g -> Decoder result +map7 func decodeA decodeB decodeC decodeD decodeE decodeF decodeG = + map6 (\a b c d e ( f, g ) -> func a b c d e f g) + decodeA + decodeB + decodeC + decodeD + decodeE + (BD.map2 Tuple.pair + decodeF + decodeG + ) + + +map8 : (a -> b -> c -> d -> e -> f -> g -> h -> result) -> Decoder a -> Decoder b -> Decoder c -> Decoder d -> Decoder e -> Decoder f -> Decoder g -> Decoder h -> Decoder result +map8 func decodeA decodeB decodeC decodeD decodeE decodeF decodeG decodeH = + map7 (\a b c d e f ( g, h ) -> func a b c d e f g h) + decodeA + decodeB + decodeC + decodeD + decodeE + decodeF + (BD.map2 Tuple.pair + decodeG + decodeH + ) + + +assocListDict : (k -> comparable) -> Decoder k -> Decoder v -> Decoder (Dict comparable k v) +assocListDict toComparable keyDecoder valueDecoder = + list (jsonPair keyDecoder valueDecoder) + |> map (Dict.fromList toComparable) + + +jsonPair : Decoder a -> Decoder b -> Decoder ( a, b ) +jsonPair = + map2 Tuple.pair + + +everySet : (a -> comparable) -> Decoder a -> Decoder (EverySet comparable a) +everySet toComparable decoder = + list decoder + |> map (EverySet.fromList toComparable) + + +nonempty : Decoder a -> Decoder (NE.Nonempty a) +nonempty decoder = + list decoder + |> andThen + (\values -> + case values of + x :: xs -> + succeed (NE.Nonempty x xs) + + [] -> + fail + ) + + +oneOrMore : Decoder a -> Decoder (OneOrMore a) +oneOrMore decoder = + BD.unsignedInt8 + |> andThen + (\idx -> + case idx of + 0 -> + map OneOrMore.one decoder + + 1 -> + map2 OneOrMore.more + (lazy (\_ -> oneOrMore decoder)) + (lazy (\_ -> oneOrMore decoder)) + + _ -> + fail + ) + + +lazy : (() -> Decoder a) -> Decoder a +lazy f = + andThen f (succeed ()) diff --git a/src/Utils/Bytes/Encode.elm b/src/Utils/Bytes/Encode.elm new file mode 100644 index 0000000000..dc497973a9 --- /dev/null +++ b/src/Utils/Bytes/Encode.elm @@ -0,0 +1,161 @@ +module Utils.Bytes.Encode exposing + ( Encoder + , assocListDict + , bool + , encode + , everySet + , float + , int + , jsonPair + , list + , maybe + , nonempty + , oneOrMore + , result + , sequence + , string + , unit + , unsignedInt8 + ) + +import Bytes +import Bytes.Encode as BE +import Compiler.Data.NonEmptyList as NE +import Compiler.Data.OneOrMore exposing (OneOrMore(..)) +import Data.Map as Dict exposing (Dict) +import Data.Set as EverySet exposing (EverySet) + + +endian : Bytes.Endianness +endian = + Bytes.BE + + +type alias Encoder = + BE.Encoder + + +unsignedInt8 : Int -> Encoder +unsignedInt8 = + BE.unsignedInt8 + + +sequence : List Encoder -> Encoder +sequence = + BE.sequence + + +encode : Encoder -> Bytes.Bytes +encode = + BE.encode + + +unit : () -> Encoder +unit () = + BE.unsignedInt8 0 + + +int : Int -> Encoder +int = + toFloat >> BE.float64 endian + + +float : Float -> Encoder +float = + BE.float64 endian + + +string : String -> Encoder +string str = + sequence + [ BE.unsignedInt32 endian (BE.getStringWidth str) + , BE.string str + ] + + +bool : Bool -> Encoder +bool value = + BE.unsignedInt8 + (if value then + 1 + + else + 0 + ) + + +list : (a -> Encoder) -> List a -> Encoder +list encoder aList = + BE.sequence + (BE.unsignedInt32 endian (List.length aList) + :: List.map encoder aList + ) + + +maybe : (a -> Encoder) -> Maybe a -> Encoder +maybe encoder maybeValue = + case maybeValue of + Just value -> + BE.sequence + [ BE.unsignedInt8 1 + , encoder value + ] + + Nothing -> + BE.unsignedInt8 0 + + +nonempty : (a -> Encoder) -> NE.Nonempty a -> Encoder +nonempty encoder (NE.Nonempty x xs) = + list encoder (x :: xs) + + +result : (x -> Encoder) -> (a -> Encoder) -> Result x a -> Encoder +result errEncoder successEncoder resultValue = + case resultValue of + Ok value -> + sequence + [ BE.unsignedInt8 0 + , successEncoder value + ] + + Err err -> + sequence + [ BE.unsignedInt8 1 + , errEncoder err + ] + + +assocListDict : (k -> k -> Order) -> (k -> Encoder) -> (v -> Encoder) -> Dict c k v -> Encoder +assocListDict keyComparison keyEncoder valueEncoder = + list (jsonPair keyEncoder valueEncoder) << List.reverse << Dict.toList keyComparison + + +jsonPair : (a -> Encoder) -> (b -> Encoder) -> ( a, b ) -> Encoder +jsonPair encoderA encoderB ( a, b ) = + BE.sequence + [ encoderA a + , encoderB b + ] + + +everySet : (a -> a -> Order) -> (a -> Encoder) -> EverySet c a -> Encoder +everySet keyComparison encoder = + list encoder << List.reverse << EverySet.toList keyComparison + + +oneOrMore : (a -> Encoder) -> OneOrMore a -> Encoder +oneOrMore encoder oneOrMore_ = + case oneOrMore_ of + One value -> + BE.sequence + [ BE.unsignedInt8 0 + , encoder value + ] + + More left right -> + BE.sequence + [ BE.unsignedInt8 1 + , oneOrMore encoder left + , oneOrMore encoder right + ] diff --git a/src/Utils/Crash.elm b/src/Utils/Crash.elm new file mode 100644 index 0000000000..76f69679bc --- /dev/null +++ b/src/Utils/Crash.elm @@ -0,0 +1,6 @@ +module Utils.Crash exposing (crash) + + +crash : String -> a +crash str = + crash str diff --git a/src/Utils/Impure.elm b/src/Utils/Impure.elm new file mode 100644 index 0000000000..0322729ec2 --- /dev/null +++ b/src/Utils/Impure.elm @@ -0,0 +1,134 @@ +module Utils.Impure exposing + ( Body(..) + , Resolver(..) + , customTask + , task + ) + +import Http +import Json.Decode as Decode +import Json.Encode as Encode +import Task exposing (Task) +import Utils.Bytes.Decode as BD +import Utils.Bytes.Encode as BE +import Utils.Crash exposing (crash) + + +type Body + = EmptyBody + | StringBody String + | JsonBody Encode.Value + | BytesBody BE.Encoder + + +type Resolver a + = Always a + | StringResolver (String -> a) + | DecoderResolver (Decode.Decoder a) + | BytesResolver (BD.Decoder a) + | Crash + + +customTask : String -> String -> List Http.Header -> Body -> Resolver a -> Task Never a +customTask method url headers body resolver = + Http.task + { method = method + , headers = headers + , url = url + , body = + case body of + EmptyBody -> + Http.emptyBody + + StringBody string -> + Http.stringBody "text/plain" string + + JsonBody value -> + Http.jsonBody value + + BytesBody encoder -> + Http.bytesBody "application/octet-stream" (BE.encode encoder) + , resolver = + case resolver of + Always x -> + Http.stringResolver (\_ -> Ok x) + + StringResolver fn -> + Http.stringResolver + (\response -> + case response of + Http.BadUrl_ url_ -> + crash ("Unexpected BadUrl: " ++ url_) + + Http.Timeout_ -> + crash "Unexpected Timeout" + + Http.NetworkError_ -> + crash "Unexpected NetworkError" + + Http.BadStatus_ metadata _ -> + crash ("Unexpected BadStatus. Status code: " ++ String.fromInt metadata.statusCode) + + Http.GoodStatus_ _ body_ -> + Ok (fn body_) + ) + + DecoderResolver decoder -> + Http.stringResolver + (\response -> + case response of + Http.BadUrl_ url_ -> + crash ("Unexpected BadUrl: " ++ url_) + + Http.Timeout_ -> + crash "Unexpected Timeout" + + Http.NetworkError_ -> + crash "Unexpected NetworkError" + + Http.BadStatus_ metadata _ -> + crash ("Unexpected BadStatus. Status code: " ++ String.fromInt metadata.statusCode) + + Http.GoodStatus_ _ body_ -> + case Decode.decodeString decoder body_ of + Ok value -> + Ok value + + Err err -> + crash ("Decoding error: " ++ Decode.errorToString err) + ) + + BytesResolver decoder -> + Http.bytesResolver + (\response -> + case response of + Http.BadUrl_ url_ -> + crash ("Unexpected BadUrl: " ++ url_) + + Http.Timeout_ -> + crash "Unexpected Timeout" + + Http.NetworkError_ -> + crash "Unexpected NetworkError" + + Http.BadStatus_ metadata _ -> + crash ("Unexpected BadStatus. Status code: " ++ String.fromInt metadata.statusCode) + + Http.GoodStatus_ _ body_ -> + case BD.decode decoder body_ of + Just value -> + Ok value + + Nothing -> + crash "Decoding bytes error..." + ) + + Crash -> + Http.stringResolver (\_ -> crash url) + , timeout = Nothing + } + + +task : String -> List Http.Header -> Body -> Resolver a -> Task Never a +task url headers body resolver = + customTask "POST" url headers body resolver diff --git a/src/Utils/Main.elm b/src/Utils/Main.elm new file mode 100644 index 0000000000..c605e73c23 --- /dev/null +++ b/src/Utils/Main.elm @@ -0,0 +1,1369 @@ +module Utils.Main exposing + ( AsyncException(..) + , ChItem + , Chan + , FilePath + , HttpExceptionContent(..) + , HttpResponse(..) + , HttpResponseHeaders + , HttpStatus(..) + , LockSharedExclusive(..) + , MVar(..) + , ReplCompletion(..) + , ReplCompletionFunc + , ReplInputT + , ReplSettings(..) + , SomeException(..) + , ThreadId + , ZipArchive(..) + , ZipEntry(..) + , binaryDecodeFileOrFail + , binaryEncodeFile + , bracket_ + , builderHPutBuilder + , dictMapM_ + , dirCanonicalizePath + , dirCreateDirectoryIfMissing + , dirDoesDirectoryExist + , dirDoesFileExist + , dirFindExecutable + , dirGetAppUserDataDirectory + , dirGetCurrentDirectory + , dirGetModificationTime + , dirListDirectory + , dirRemoveDirectoryRecursive + , dirRemoveFile + , dirWithCurrentDirectory + , eitherLefts + , envGetArgs + , envGetProgName + , envLookupEnv + , filterM + , find + , findMax + , foldM + , foldl1_ + , foldr1 + , forkIO + , fpAddExtension + , fpAddTrailingPathSeparator + , fpCombine + , fpDropExtension + , fpDropFileName + , fpIsRelative + , fpJoinPath + , fpMakeRelative + , fpPathSeparator + , fpSplitDirectories + , fpSplitExtension + , fpSplitFileName + , fpTakeDirectory + , fpTakeExtension + , fpTakeFileName + , httpExceptionContentDecoder + , httpExceptionContentEncoder + , httpHLocation + , httpResponseHeaders + , httpResponseStatus + , httpStatusCode + , indexedZipWithA + , keysSet + , liftIOInputT + , liftInputT + , lines + , listGroupBy + , listLookup + , listMaximum + , listTraverse + , listTraverse_ + , lockWithFileLock + , mVarDecoder + , mVarEncoder + , mapFindMin + , mapFromKeys + , mapFromListWith + , mapInsertWith + , mapIntersectionWith + , mapIntersectionWithKey + , mapLookupMin + , mapM_ + , mapMapKeys + , mapMapMaybe + , mapMinViewWithKey + , mapTraverse + , mapTraverseResult + , mapTraverseWithKey + , mapTraverseWithKeyResult + , mapUnionWith + , mapUnions + , mapUnionsWith + , maybeEncoder + , maybeMapM + , maybeTraverseTask + , newChan + , newEmptyMVar + , newMVar + , nodeGetDirname + , nodeMathRandom + , nonEmptyListTraverse + , putMVar + , readChan + , readMVar + , replCompleteWord + , replGetInputLine + , replGetInputLineWithInitial + , replRunInputT + , replWithInterrupt + , sequenceADict + , sequenceDictMaybe + , sequenceDictResult + , sequenceDictResult_ + , sequenceListMaybe + , sequenceNonemptyListResult + , someExceptionDecoder + , someExceptionEncoder + , takeMVar + , unlines + , unzip3 + , writeChan + , zipWithM + ) + +import Basics.Extra exposing (flip) +import Compiler.Data.Index as Index +import Compiler.Data.NonEmptyList as NE +import Compiler.Reporting.Result as R +import Control.Monad.State.Strict as State +import Data.Map as Map exposing (Dict) +import Data.Set as EverySet exposing (EverySet) +import Http +import Json.Decode as Decode +import Json.Encode as Encode +import Maybe.Extra as Maybe +import Prelude +import Process +import System.Exit as Exit +import System.IO as IO +import Task exposing (Task) +import Time +import Utils.Bytes.Decode as BD +import Utils.Bytes.Encode as BE +import Utils.Crash exposing (crash) +import Utils.Impure as Impure +import Utils.Task.Extra as Task + + +liftInputT : Task Never () -> ReplInputT () +liftInputT = + identity + + +liftIOInputT : Task Never a -> ReplInputT a +liftIOInputT = + identity + + +fpDropFileName : FilePath -> FilePath +fpDropFileName path = + case List.reverse (String.split "/" path) of + _ :: tail -> + List.reverse ("" :: tail) + |> String.join "/" + + [] -> + "" + + +{-| An alias for ``. + +Combine two paths with a path separator. If the second path starts with a +path separator or a drive letter, then it returns the second. +The intention is that readFile `(dir file)` will access the same file +as `setCurrentDirectory dir; readFile file`. + +-} +fpCombine : FilePath -> FilePath -> FilePath +fpCombine path1 path2 = + if String.startsWith "/" path2 || String.startsWith path1 path2 then + path2 + + else + path1 ++ "/" ++ path2 + + +fpAddExtension : FilePath -> String -> FilePath +fpAddExtension path extension = + if String.startsWith "." extension then + path ++ extension + + else + path ++ "." ++ extension + + +mapFromListWith : (k -> comparable) -> (a -> a -> a) -> List ( k, a ) -> Dict comparable k a +mapFromListWith toComparable f = + List.foldl + (\( k, a ) -> + Map.update toComparable k (Maybe.map (flip f a)) + ) + Map.empty + + +maybeEncoder : (a -> BE.Encoder) -> Maybe a -> BE.Encoder +maybeEncoder = + BE.maybe + + +eitherLefts : List (Result e a) -> List e +eitherLefts = + List.filterMap + (\res -> + case res of + Ok _ -> + Nothing + + Err e -> + Just e + ) + + +mapFromKeys : (k -> comparable) -> (k -> v) -> List k -> Dict comparable k v +mapFromKeys toComparable f = + List.map (\k -> ( k, f k )) + >> Map.fromList toComparable + + +filterM : (a -> Task Never Bool) -> List a -> Task Never (List a) +filterM p = + List.foldr + (\x acc -> + Task.apply acc + (Task.fmap + (\flg -> + if flg then + (::) x + + else + identity + ) + (p x) + ) + ) + (Task.pure []) + + +find : (k -> comparable) -> k -> Dict comparable k a -> a +find toComparable k items = + case Map.get toComparable k items of + Just item -> + item + + Nothing -> + crash "Map.!: given key is not an element in the map" + + +findMax : (k -> k -> Order) -> Dict comparable k a -> ( k, a ) +findMax keyComparison items = + case List.reverse (Map.toList keyComparison items) of + item :: _ -> + item + + _ -> + crash "Error: empty map has no maximal element" + + +mapLookupMin : Dict comparable comparable a -> Maybe ( comparable, a ) +mapLookupMin dict = + case List.sortBy Tuple.first (Map.toList compare dict) of + firstElem :: _ -> + Just firstElem + + _ -> + Nothing + + +mapFindMin : Dict comparable comparable a -> ( comparable, a ) +mapFindMin dict = + case List.sortBy Tuple.first (Map.toList compare dict) of + firstElem :: _ -> + firstElem + + _ -> + crash "Error: empty map has no minimal element" + + +mapInsertWith : (k -> comparable) -> (a -> a -> a) -> k -> a -> Dict comparable k a -> Dict comparable k a +mapInsertWith toComparable f k a = + Map.update toComparable k (Maybe.map (f a) >> Maybe.withDefault a >> Just) + + +mapIntersectionWith : (k -> comparable) -> (k -> k -> Order) -> (a -> b -> c) -> Dict comparable k a -> Dict comparable k b -> Dict comparable k c +mapIntersectionWith toComparable keyComparison func = + mapIntersectionWithKey toComparable keyComparison (\_ -> func) + + +mapIntersectionWithKey : (k -> comparable) -> (k -> k -> Order) -> (k -> a -> b -> c) -> Dict comparable k a -> Dict comparable k b -> Dict comparable k c +mapIntersectionWithKey toComparable keyComparison func dict1 dict2 = + Map.merge keyComparison (\_ _ -> identity) (\k v1 v2 -> Map.insert toComparable k (func k v1 v2)) (\_ _ -> identity) dict1 dict2 Map.empty + + +mapUnionWith : (k -> comparable) -> (k -> k -> Order) -> (a -> a -> a) -> Dict comparable k a -> Dict comparable k a -> Dict comparable k a +mapUnionWith toComparable keyComparison f a b = + Map.merge keyComparison (Map.insert toComparable) (\k va vb -> Map.insert toComparable k (f va vb)) (Map.insert toComparable) a b Map.empty + + +mapUnionsWith : (k -> comparable) -> (k -> k -> Order) -> (a -> a -> a) -> List (Dict comparable k a) -> Dict comparable k a +mapUnionsWith toComparable keyComparison f = + List.foldl (mapUnionWith toComparable keyComparison f) Map.empty + + +mapUnions : List (Dict comparable k a) -> Dict comparable k a +mapUnions = + List.foldr Map.union Map.empty + + +foldM : (b -> a -> R.RResult info warnings error b) -> b -> List a -> R.RResult info warnings error b +foldM f b = + List.foldl (\a -> R.bind (\acc -> f acc a)) (R.ok b) + + +indexedZipWithA : (Index.ZeroBased -> a -> b -> R.RResult info warnings error c) -> List a -> List b -> R.RResult info warnings error (Index.VerifiedList c) +indexedZipWithA func listX listY = + case Index.indexedZipWith func listX listY of + Index.LengthMatch xs -> + sequenceAList xs + |> R.fmap Index.LengthMatch + + Index.LengthMismatch x y -> + R.pure (Index.LengthMismatch x y) + + +sequenceADict : (k -> comparable) -> (k -> k -> Order) -> Dict comparable k (R.RResult i w e v) -> R.RResult i w e (Dict comparable k v) +sequenceADict toComparable keyComparison = + Map.foldr keyComparison (\k x acc -> R.apply acc (R.fmap (Map.insert toComparable k) x)) (R.pure Map.empty) + + +sequenceAList : List (R.RResult i w e v) -> R.RResult i w e (List v) +sequenceAList = + List.foldr (\x acc -> R.apply acc (R.fmap (::) x)) (R.pure []) + + +sequenceDictMaybe : (k -> comparable) -> (k -> k -> Order) -> Dict comparable k (Maybe a) -> Maybe (Dict comparable k a) +sequenceDictMaybe toComparable keyComparison = + Map.foldr keyComparison (\k -> Maybe.map2 (Map.insert toComparable k)) (Just Map.empty) + + +sequenceDictResult : (k -> comparable) -> (k -> k -> Order) -> Dict comparable k (Result e v) -> Result e (Dict comparable k v) +sequenceDictResult toComparable keyComparison = + Map.foldr keyComparison (\k -> Result.map2 (Map.insert toComparable k)) (Ok Map.empty) + + +sequenceDictResult_ : (k -> comparable) -> (k -> k -> Order) -> Dict comparable k (Result e a) -> Result e () +sequenceDictResult_ toComparable keyComparison = + sequenceDictResult toComparable keyComparison >> Result.map (\_ -> ()) + + +sequenceListMaybe : List (Maybe a) -> Maybe (List a) +sequenceListMaybe = + List.foldr (Maybe.map2 (::)) (Just []) + + +sequenceNonemptyListResult : NE.Nonempty (Result e v) -> Result e (NE.Nonempty v) +sequenceNonemptyListResult (NE.Nonempty x xs) = + List.foldr (\a acc -> Result.map2 NE.cons a acc) (Result.map NE.singleton x) xs + + +keysSet : (k -> comparable) -> (k -> k -> Order) -> Dict comparable k a -> EverySet comparable k +keysSet toComparable keyComparison = + Map.keys keyComparison >> EverySet.fromList toComparable + + +unzip3 : List ( a, b, c ) -> ( List a, List b, List c ) +unzip3 pairs = + let + step : ( a, b, c ) -> ( List a, List b, List c ) -> ( List a, List b, List c ) + step ( x, y, z ) ( xs, ys, zs ) = + ( x :: xs, y :: ys, z :: zs ) + in + List.foldr step ( [], [], [] ) pairs + + +mapM_ : (a -> Task Never b) -> List a -> Task Never () +mapM_ f = + let + c : a -> Task Never () -> Task Never () + c x k = + Task.bind (\_ -> k) (f x) + in + List.foldr c (Task.pure ()) + + +dictMapM_ : (k -> k -> Order) -> (a -> Task Never b) -> Dict c k a -> Task Never () +dictMapM_ keyComparison f = + let + c : k -> a -> Task Never () -> Task Never () + c _ x k = + Task.bind (\_ -> k) (f x) + in + Map.foldl keyComparison c (Task.pure ()) + + +maybeMapM : (a -> Maybe b) -> List a -> Maybe (List b) +maybeMapM = + listMaybeTraverse + + +mapMapKeys : (k2 -> comparable) -> (k1 -> k1 -> Order) -> (k1 -> k2) -> Dict comparable k1 a -> Dict comparable k2 a +mapMapKeys toComparable keyComparison f = + Map.fromList toComparable << Map.foldl keyComparison (\k x xs -> ( f k, x ) :: xs) [] + + +mapMinViewWithKey : (k -> comparable) -> (k -> k -> Order) -> (( k, a ) -> comparable) -> Dict comparable k a -> Maybe ( ( k, a ), Dict comparable k a ) +mapMinViewWithKey toComparable keyComparison compare dict = + case List.sortBy compare (Map.toList keyComparison dict) of + first :: tail -> + Just ( first, Map.fromList toComparable tail ) + + _ -> + Nothing + + +mapMapMaybe : (k -> comparable) -> (k -> k -> Order) -> (a -> Maybe b) -> Dict comparable k a -> Dict comparable k b +mapMapMaybe toComparable keyComparison func = + Map.toList keyComparison + >> List.filterMap (\( k, a ) -> Maybe.map (Tuple.pair k) (func a)) + >> Map.fromList toComparable + + +mapTraverse : (k -> comparable) -> (k -> k -> Order) -> (a -> Task Never b) -> Dict comparable k a -> Task Never (Dict comparable k b) +mapTraverse toComparable keyComparison f = + mapTraverseWithKey toComparable keyComparison (\_ -> f) + + +mapTraverseWithKey : (k -> comparable) -> (k -> k -> Order) -> (k -> a -> Task Never b) -> Dict comparable k a -> Task Never (Dict comparable k b) +mapTraverseWithKey toComparable keyComparison f = + Map.foldl keyComparison + (\k a -> Task.bind (\c -> Task.fmap (\va -> Map.insert toComparable k va c) (f k a))) + (Task.pure Map.empty) + + +mapTraverseResult : (k -> comparable) -> (k -> k -> Order) -> (a -> Result e b) -> Dict comparable k a -> Result e (Dict comparable k b) +mapTraverseResult toComparable keyComparison f = + mapTraverseWithKeyResult toComparable keyComparison (\_ -> f) + + +mapTraverseWithKeyResult : (k -> comparable) -> (k -> k -> Order) -> (k -> a -> Result e b) -> Dict comparable k a -> Result e (Dict comparable k b) +mapTraverseWithKeyResult toComparable keyComparison f = + Map.foldl keyComparison + (\k a -> Result.map2 (Map.insert toComparable k) (f k a)) + (Ok Map.empty) + + +listTraverse : (a -> Task Never b) -> List a -> Task Never (List b) +listTraverse = + Task.mapM + + +listMaybeTraverse : (a -> Maybe b) -> List a -> Maybe (List b) +listMaybeTraverse f = + List.foldr (\a -> Maybe.andThen (\c -> Maybe.map (\va -> va :: c) (f a))) + (Just []) + + +nonEmptyListTraverse : (a -> Task Never b) -> NE.Nonempty a -> Task Never (NE.Nonempty b) +nonEmptyListTraverse f (NE.Nonempty x list) = + List.foldl (\a -> Task.bind (\c -> Task.fmap (\va -> NE.cons va c) (f a))) + (Task.fmap NE.singleton (f x)) + list + + +listTraverse_ : (a -> Task Never b) -> List a -> Task Never () +listTraverse_ f = + listTraverse f + >> Task.fmap (\_ -> ()) + + +maybeTraverseTask : (a -> Task x b) -> Maybe a -> Task x (Maybe b) +maybeTraverseTask f a = + case Maybe.map f a of + Just b -> + Task.fmap Just b + + Nothing -> + Task.pure Nothing + + +zipWithM : (a -> b -> Maybe c) -> List a -> List b -> Maybe (List c) +zipWithM f xs ys = + List.map2 f xs ys + |> Maybe.combine + + +listGroupBy : (a -> a -> Bool) -> List a -> List (List a) +listGroupBy p list = + case list of + [] -> + [] + + x :: xs -> + xs + |> List.foldl + (\current ( previous, ys, acc ) -> + if p previous current then + ( current, current :: ys, acc ) + + else + ( current, [ current ], ys :: acc ) + ) + ( x, [ x ], [] ) + |> (\( _, ys, acc ) -> + ys :: acc + ) + |> List.map List.reverse + |> List.reverse + + +listMaximum : (a -> a -> Order) -> List a -> a +listMaximum compare xs = + case List.sortWith (flip compare) xs of + x :: _ -> + x + + [] -> + crash "maximum: empty structure" + + +listLookup : a -> List ( a, b ) -> Maybe b +listLookup key list = + case list of + [] -> + Nothing + + ( x, y ) :: xys -> + if key == x then + Just y + + else + listLookup key xys + + +foldl1 : (a -> a -> a) -> List a -> a +foldl1 f xs = + let + mf : a -> Maybe a -> Maybe a + mf x m = + Just + (case m of + Nothing -> + x + + Just y -> + f x y + ) + in + case List.foldl mf Nothing xs of + Just a -> + a + + Nothing -> + crash "foldl1: empty structure" + + +foldl1_ : (a -> a -> a) -> List a -> a +foldl1_ f = + foldl1 (\a b -> f b a) + + +foldr1 : (a -> a -> a) -> List a -> a +foldr1 f xs = + let + mf : a -> Maybe a -> Maybe a + mf x m = + Just + (case m of + Nothing -> + x + + Just y -> + f x y + ) + in + case List.foldr mf Nothing xs of + Just a -> + a + + Nothing -> + crash "foldr1: empty structure" + + +lines : String -> List String +lines = + String.split "\n" + + +unlines : List String -> String +unlines xs = + String.join "\n" xs ++ "\n" + + + +-- GHC.IO + + +type alias FilePath = + String + + + +-- System.FilePath + + +fpSplitDirectories : String -> List String +fpSplitDirectories path = + String.split "/" path + |> List.filter ((/=) "") + |> (\a -> + (if String.startsWith "/" path then + [ "/" ] + + else + [] + ) + ++ a + ) + + +fpSplitExtension : String -> ( String, String ) +fpSplitExtension filename = + case List.reverse (String.split "/" filename) of + lastPart :: otherParts -> + case List.reverse (String.indexes "." lastPart) of + index :: _ -> + ( (String.left index lastPart :: otherParts) + |> List.reverse + |> String.join "/" + , String.dropLeft index lastPart + ) + + [] -> + ( filename, "" ) + + [] -> + ( "", "" ) + + +fpJoinPath : List String -> String +fpJoinPath paths = + case paths of + "/" :: tail -> + "/" ++ String.join "/" tail + + _ -> + String.join "/" paths + + +fpMakeRelative : FilePath -> FilePath -> FilePath +fpMakeRelative root path = + if String.startsWith root path then + String.dropLeft (String.length root + 1) path + + else + path + + +fpAddTrailingPathSeparator : FilePath -> FilePath +fpAddTrailingPathSeparator path = + if String.endsWith "/" path then + path + + else + path ++ "/" + + +fpPathSeparator : Char +fpPathSeparator = + '/' + + +fpIsRelative : FilePath -> Bool +fpIsRelative = + not << String.startsWith "/" + + +fpTakeFileName : FilePath -> FilePath +fpTakeFileName filename = + Prelude.last (String.split "/" filename) + + +fpSplitFileName : FilePath -> ( String, String ) +fpSplitFileName filename = + case List.reverse (String.indexes "/" filename) of + index :: _ -> + ( String.left (index + 1) filename, String.dropLeft (index + 1) filename ) + + _ -> + ( "./", filename ) + + +fpTakeExtension : FilePath -> String +fpTakeExtension = + Tuple.second << fpSplitExtension + + +fpDropExtension : FilePath -> FilePath +fpDropExtension = + Tuple.first << fpSplitExtension + + +fpTakeDirectory : FilePath -> FilePath +fpTakeDirectory filename = + case List.reverse (String.split "/" filename) of + [] -> + "." + + "" :: "" :: [] -> + "/" + + "" :: _ :: other -> + String.join "/" (List.reverse other) + + _ :: other -> + String.join "/" (List.reverse other) + + + +-- System.FileLock + + +type LockSharedExclusive + = LockExclusive + + +lockWithFileLock : String -> LockSharedExclusive -> (() -> Task Never a) -> Task Never a +lockWithFileLock path mode ioFunc = + case mode of + LockExclusive -> + lockFile path + |> Task.bind ioFunc + |> Task.bind + (\a -> + unlockFile path + |> Task.fmap (\_ -> a) + ) + + +lockFile : FilePath -> Task Never () +lockFile path = + Impure.task "lockFile" + [] + (Impure.StringBody path) + (Impure.Always ()) + + +unlockFile : FilePath -> Task Never () +unlockFile path = + Impure.task "unlockFile" + [] + (Impure.StringBody path) + (Impure.Always ()) + + + +-- System.Directory + + +dirDoesFileExist : FilePath -> Task Never Bool +dirDoesFileExist filename = + Impure.task "dirDoesFileExist" + [] + (Impure.StringBody filename) + (Impure.DecoderResolver Decode.bool) + + +dirFindExecutable : FilePath -> Task Never (Maybe FilePath) +dirFindExecutable filename = + Impure.task "dirFindExecutable" + [] + (Impure.StringBody filename) + (Impure.DecoderResolver (Decode.maybe Decode.string)) + + +dirCreateDirectoryIfMissing : Bool -> FilePath -> Task Never () +dirCreateDirectoryIfMissing createParents filename = + Impure.task "dirCreateDirectoryIfMissing" + [] + (Impure.JsonBody + (Encode.object + [ ( "createParents", Encode.bool createParents ) + , ( "filename", Encode.string filename ) + ] + ) + ) + (Impure.Always ()) + + +dirGetCurrentDirectory : Task Never String +dirGetCurrentDirectory = + Impure.task "dirGetCurrentDirectory" + [] + Impure.EmptyBody + (Impure.StringResolver identity) + + +dirGetAppUserDataDirectory : FilePath -> Task Never FilePath +dirGetAppUserDataDirectory filename = + Impure.task "dirGetAppUserDataDirectory" + [] + (Impure.StringBody filename) + (Impure.StringResolver identity) + + +dirGetModificationTime : FilePath -> Task Never Time.Posix +dirGetModificationTime filename = + Impure.task "dirGetModificationTime" + [] + (Impure.StringBody filename) + (Impure.DecoderResolver (Decode.map Time.millisToPosix Decode.int)) + + +dirRemoveFile : FilePath -> Task Never () +dirRemoveFile path = + Impure.task "dirRemoveFile" + [] + (Impure.StringBody path) + (Impure.Always ()) + + +dirRemoveDirectoryRecursive : FilePath -> Task Never () +dirRemoveDirectoryRecursive path = + Impure.task "dirRemoveDirectoryRecursive" + [] + (Impure.StringBody path) + (Impure.Always ()) + + +dirDoesDirectoryExist : FilePath -> Task Never Bool +dirDoesDirectoryExist path = + Impure.task "dirDoesDirectoryExist" + [] + (Impure.StringBody path) + (Impure.DecoderResolver Decode.bool) + + +dirCanonicalizePath : FilePath -> Task Never FilePath +dirCanonicalizePath path = + Impure.task "dirCanonicalizePath" + [] + (Impure.StringBody path) + (Impure.StringResolver identity) + + +dirWithCurrentDirectory : FilePath -> Task Never a -> Task Never a +dirWithCurrentDirectory dir action = + dirGetCurrentDirectory + |> Task.bind + (\currentDir -> + bracket_ + (Impure.task "dirWithCurrentDirectory" + [] + (Impure.StringBody dir) + (Impure.Always ()) + ) + (Impure.task "dirWithCurrentDirectory" + [] + (Impure.StringBody currentDir) + (Impure.Always ()) + ) + action + ) + + +dirListDirectory : FilePath -> Task Never (List FilePath) +dirListDirectory path = + Impure.task "dirListDirectory" + [] + (Impure.StringBody path) + (Impure.DecoderResolver (Decode.list Decode.string)) + + + +-- System.Environment + + +envLookupEnv : String -> Task Never (Maybe String) +envLookupEnv name = + Impure.task "envLookupEnv" + [] + (Impure.StringBody name) + (Impure.DecoderResolver (Decode.maybe Decode.string)) + + +envGetProgName : Task Never String +envGetProgName = + Task.pure "guida" + + +envGetArgs : Task Never (List String) +envGetArgs = + Impure.task "envGetArgs" + [] + Impure.EmptyBody + (Impure.DecoderResolver (Decode.list Decode.string)) + + + +-- Codec.Archive.Zip + + +type ZipArchive + = ZipArchive (List ZipEntry) + + +type ZipEntry + = ZipEntry + { eRelativePath : FilePath + , eData : String + } + + + +-- Network.HTTP.Client + + +type HttpExceptionContent + = StatusCodeException (HttpResponse ()) String + | TooManyRedirects (List (HttpResponse ())) + | ConnectionFailure SomeException + + +type HttpResponse body + = HttpResponse + { responseStatus : HttpStatus + , responseHeaders : HttpResponseHeaders + } + + +type alias HttpResponseHeaders = + List ( String, String ) + + +httpResponseStatus : HttpResponse body -> HttpStatus +httpResponseStatus (HttpResponse { responseStatus }) = + responseStatus + + +httpStatusCode : HttpStatus -> Int +httpStatusCode (HttpStatus statusCode _) = + statusCode + + +httpResponseHeaders : HttpResponse body -> HttpResponseHeaders +httpResponseHeaders (HttpResponse { responseHeaders }) = + responseHeaders + + +httpHLocation : String +httpHLocation = + "Location" + + +type HttpStatus + = HttpStatus Int String + + + +-- Control.Exception + + +type SomeException + = SomeException + + +type AsyncException + = UserInterrupt + + +bracket : Task Never a -> (a -> Task Never b) -> (a -> Task Never c) -> Task Never c +bracket before after thing = + before + |> Task.bind + (\a -> + thing a + |> Task.bind + (\r -> + after a + |> Task.fmap (\_ -> r) + ) + ) + + +bracket_ : Task Never a -> Task Never b -> Task Never c -> Task Never c +bracket_ before after thing = + bracket before (always after) (always thing) + + + +-- Control.Concurrent + + +type alias ThreadId = + Process.Id + + +forkIO : Task Never () -> Task Never ThreadId +forkIO = + Process.spawn + + + +-- Control.Concurrent.MVar + + +type MVar a + = MVar Int + + +newMVar : (a -> BE.Encoder) -> a -> Task Never (MVar a) +newMVar toEncoder value = + newEmptyMVar + |> Task.bind + (\mvar -> + putMVar toEncoder mvar value + |> Task.fmap (\_ -> mvar) + ) + + +readMVar : BD.Decoder a -> MVar a -> Task Never a +readMVar decoder (MVar ref) = + Impure.task "readMVar" + [] + (Impure.StringBody (String.fromInt ref)) + (Impure.BytesResolver decoder) + + +modifyMVar : BD.Decoder a -> (a -> BE.Encoder) -> MVar a -> (a -> Task Never ( a, b )) -> Task Never b +modifyMVar decoder toEncoder m io = + takeMVar decoder m + |> Task.bind io + |> Task.bind + (\( a, b ) -> + putMVar toEncoder m a + |> Task.fmap (\_ -> b) + ) + + +takeMVar : BD.Decoder a -> MVar a -> Task Never a +takeMVar decoder (MVar ref) = + Impure.task "takeMVar" + [] + (Impure.StringBody (String.fromInt ref)) + (Impure.BytesResolver decoder) + + +putMVar : (a -> BE.Encoder) -> MVar a -> a -> Task Never () +putMVar encoder (MVar ref) value = + Impure.task "putMVar" + [ Http.header "id" (String.fromInt ref) ] + (Impure.BytesBody (encoder value)) + (Impure.Always ()) + + +newEmptyMVar : Task Never (MVar a) +newEmptyMVar = + Impure.task "newEmptyMVar" + [] + Impure.EmptyBody + (Impure.DecoderResolver (Decode.map MVar Decode.int)) + + + +-- Control.Concurrent.Chan + + +type Chan a + = Chan (MVar (Stream a)) (MVar (Stream a)) + + +type alias Stream a = + MVar (ChItem a) + + +type ChItem a + = ChItem a (Stream a) + + +newChan : (MVar (ChItem a) -> BE.Encoder) -> Task Never (Chan a) +newChan toEncoder = + newEmptyMVar + |> Task.bind + (\hole -> + newMVar toEncoder hole + |> Task.bind + (\readVar -> + newMVar toEncoder hole + |> Task.fmap + (\writeVar -> + Chan readVar writeVar + ) + ) + ) + + +readChan : BD.Decoder a -> Chan a -> Task Never a +readChan decoder (Chan readVar _) = + modifyMVar mVarDecoder mVarEncoder readVar <| + \read_end -> + readMVar (chItemDecoder decoder) read_end + |> Task.fmap + (\(ChItem val new_read_end) -> + -- Use readMVar here, not takeMVar, + -- else dupChan doesn't work + ( new_read_end, val ) + ) + + +writeChan : (a -> BE.Encoder) -> Chan a -> a -> Task Never () +writeChan toEncoder (Chan _ writeVar) val = + newEmptyMVar + |> Task.bind + (\new_hole -> + takeMVar mVarDecoder writeVar + |> Task.bind + (\old_hole -> + putMVar (chItemEncoder toEncoder) old_hole (ChItem val new_hole) + |> Task.bind (\_ -> putMVar mVarEncoder writeVar new_hole) + ) + ) + + + +-- Data.ByteString.Builder + + +builderHPutBuilder : IO.Handle -> String -> Task Never () +builderHPutBuilder = + IO.hPutStr + + + +-- Data.Binary + + +binaryDecodeFileOrFail : BD.Decoder a -> FilePath -> Task Never (Result ( Int, String ) a) +binaryDecodeFileOrFail decoder filename = + Impure.task "binaryDecodeFileOrFail" + [] + (Impure.StringBody filename) + (Impure.BytesResolver (BD.map Ok decoder)) + + +binaryEncodeFile : (a -> BE.Encoder) -> FilePath -> a -> Task Never () +binaryEncodeFile toEncoder path value = + Impure.task "write" + [ Http.header "path" path ] + (Impure.BytesBody (toEncoder value)) + (Impure.Always ()) + + + +-- System.Console.Haskeline + + +type ReplSettings + = ReplSettings + { historyFile : Maybe String + , autoAddHistory : Bool + , complete : ReplCompletionFunc + } + + +type alias ReplInputT a = + Task Never a + + +type ReplCompletion + = ReplCompletion String String Bool + + +type ReplCompletionFunc + = ReplCompletionFunc + + +replRunInputT : ReplSettings -> ReplInputT Exit.ExitCode -> State.StateT s Exit.ExitCode +replRunInputT _ io = + State.liftIO io + + +replWithInterrupt : ReplInputT a -> ReplInputT a +replWithInterrupt = + identity + + +replCompleteWord : Maybe Char -> String -> (String -> State.StateT a (List ReplCompletion)) -> ReplCompletionFunc +replCompleteWord _ _ _ = + -- FIXME + ReplCompletionFunc + + +replGetInputLine : String -> ReplInputT (Maybe String) +replGetInputLine prompt = + Impure.task "replGetInputLine" + [] + (Impure.StringBody prompt) + (Impure.DecoderResolver (Decode.maybe Decode.string)) + + +replGetInputLineWithInitial : String -> ( String, String ) -> ReplInputT (Maybe String) +replGetInputLineWithInitial prompt ( left, right ) = + replGetInputLine (left ++ prompt ++ right) + + + +-- NODE + + +nodeGetDirname : Task Never String +nodeGetDirname = + Impure.task "nodeGetDirname" + [] + Impure.EmptyBody + (Impure.StringResolver identity) + + +nodeMathRandom : Task Never Float +nodeMathRandom = + Impure.task "nodeMathRandom" + [] + Impure.EmptyBody + (Impure.DecoderResolver Decode.float) + + + +-- ENCODERS and DECODERS + + +mVarDecoder : BD.Decoder (MVar a) +mVarDecoder = + BD.map MVar BD.int + + +mVarEncoder : MVar a -> BE.Encoder +mVarEncoder (MVar ref) = + BE.int ref + + +chItemEncoder : (a -> BE.Encoder) -> ChItem a -> BE.Encoder +chItemEncoder valueEncoder (ChItem value hole) = + BE.sequence + [ valueEncoder value + , mVarEncoder hole + ] + + +chItemDecoder : BD.Decoder a -> BD.Decoder (ChItem a) +chItemDecoder decoder = + BD.map2 ChItem + decoder + mVarDecoder + + +someExceptionEncoder : SomeException -> BE.Encoder +someExceptionEncoder _ = + BE.unsignedInt8 0 + + +someExceptionDecoder : BD.Decoder SomeException +someExceptionDecoder = + BD.unsignedInt8 + |> BD.map (\_ -> SomeException) + + +httpResponseEncoder : HttpResponse body -> BE.Encoder +httpResponseEncoder (HttpResponse httpResponse) = + BE.sequence + [ httpStatusEncoder httpResponse.responseStatus + , httpResponseHeadersEncoder httpResponse.responseHeaders + ] + + +httpResponseDecoder : BD.Decoder (HttpResponse body) +httpResponseDecoder = + BD.map2 + (\responseStatus responseHeaders -> + HttpResponse + { responseStatus = responseStatus + , responseHeaders = responseHeaders + } + ) + httpStatusDecoder + httpResponseHeadersDecoder + + +httpStatusEncoder : HttpStatus -> BE.Encoder +httpStatusEncoder (HttpStatus statusCode statusMessage) = + BE.sequence + [ BE.int statusCode + , BE.string statusMessage + ] + + +httpStatusDecoder : BD.Decoder HttpStatus +httpStatusDecoder = + BD.map2 HttpStatus + BD.int + BD.string + + +httpResponseHeadersEncoder : HttpResponseHeaders -> BE.Encoder +httpResponseHeadersEncoder = + BE.list (BE.jsonPair BE.string BE.string) + + +httpResponseHeadersDecoder : BD.Decoder HttpResponseHeaders +httpResponseHeadersDecoder = + BD.list (BD.jsonPair BD.string BD.string) + + +httpExceptionContentEncoder : HttpExceptionContent -> BE.Encoder +httpExceptionContentEncoder httpExceptionContent = + case httpExceptionContent of + StatusCodeException response body -> + BE.sequence + [ BE.unsignedInt8 0 + , httpResponseEncoder response + , BE.string body + ] + + TooManyRedirects responses -> + BE.sequence + [ BE.unsignedInt8 1 + , BE.list httpResponseEncoder responses + ] + + ConnectionFailure someException -> + BE.sequence + [ BE.unsignedInt8 2 + , someExceptionEncoder someException + ] + + +httpExceptionContentDecoder : BD.Decoder HttpExceptionContent +httpExceptionContentDecoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.map2 StatusCodeException + httpResponseDecoder + BD.string + + 1 -> + BD.map TooManyRedirects (BD.list httpResponseDecoder) + + 2 -> + BD.map ConnectionFailure someExceptionDecoder + + _ -> + BD.fail + ) diff --git a/src/Utils/Task/Extra.elm b/src/Utils/Task/Extra.elm new file mode 100644 index 0000000000..ca1804deee --- /dev/null +++ b/src/Utils/Task/Extra.elm @@ -0,0 +1,104 @@ +module Utils.Task.Extra exposing + ( apply + , bind + , eio + , fmap + , io + , mapM + , mio + , pure + , run + , throw + , void + ) + +import Task exposing (Task) + + + +-- TASKS + + +run : Task x a -> Task Never (Result x a) +run task = + task + |> Task.map Ok + |> Task.onError (Err >> Task.succeed) + + +throw : x -> Task x a +throw = + Task.fail + + + +-- IO + + +io : Task Never a -> Task x a +io work = + Task.mapError never work + + +mio : x -> Task Never (Maybe a) -> Task x a +mio x work = + work + |> Task.mapError never + |> Task.andThen + (\m -> + case m of + Just a -> + Task.succeed a + + Nothing -> + Task.fail x + ) + + +eio : (x -> y) -> Task Never (Result x a) -> Task y a +eio func work = + work + |> Task.mapError never + |> Task.andThen + (\m -> + case m of + Ok a -> + Task.succeed a + + Err err -> + func err |> Task.fail + ) + + + +-- INSTANCES + + +void : Task x a -> Task x () +void = + Task.map (always ()) + + +pure : a -> Task x a +pure = + Task.succeed + + +apply : Task x a -> Task x (a -> b) -> Task x b +apply ma mf = + bind (\f -> bind (pure << f) ma) mf + + +fmap : (a -> b) -> Task x a -> Task x b +fmap = + Task.map + + +bind : (a -> Task x b) -> Task x a -> Task x b +bind = + Task.andThen + + +mapM : (a -> Task x b) -> List a -> Task x (List b) +mapM f = + List.map f >> Task.sequence diff --git a/terminal/impl/Terminal.hs b/terminal/impl/Terminal.hs deleted file mode 100644 index a8751bceed..0000000000 --- a/terminal/impl/Terminal.hs +++ /dev/null @@ -1,375 +0,0 @@ -module Terminal - ( app - , Command(..) - , Summary(..) - , Flags, noFlags, flags, (|--) - , Flag, flag, onOff - , Parser(..) - , Args, noArgs, required, optional, zeroOrMore, oneOrMore, oneOf - , require0, require1, require2, require3, require4, require5 - , RequiredArgs, args, exactly, (!), (?), (...) - ) - where - - -import qualified Data.List as List -import qualified Data.Maybe as Maybe -import qualified System.Directory as Dir -import qualified System.Environment as Env -import qualified System.Exit as Exit -import qualified System.FilePath as FP -import System.FilePath (()) -import GHC.IO.Encoding (setLocaleEncoding, utf8) -import System.IO (hPutStr, hPutStrLn, stdout) -import qualified Text.PrettyPrint.ANSI.Leijen as P -import qualified Text.Read as Read - -import qualified Elm.Version as V -import Terminal.Internal -import qualified Terminal.Chomp as Chomp -import qualified Terminal.Error as Error - - - --- COMMAND - - -_command :: String -> P.Doc -> Args args -> Flags flags -> (args -> flags -> IO ()) -> IO () -_command details example args_ flags_ callback = - do setLocaleEncoding utf8 - argStrings <- Env.getArgs - case argStrings of - ["--version"] -> - do hPutStrLn stdout (V.toChars V.compiler) - Exit.exitSuccess - - chunks -> - if elem "--help" chunks then - Error.exitWithHelp Nothing details example args_ flags_ - - else - case snd $ Chomp.chomp Nothing chunks args_ flags_ of - Right (argsValue, flagValue) -> - callback argsValue flagValue - - Left err -> - Error.exitWithError err - - - --- APP - - -app :: P.Doc -> P.Doc -> [Command] -> IO () -app intro outro commands = - do setLocaleEncoding utf8 - argStrings <- Env.getArgs - case argStrings of - [] -> - Error.exitWithOverview intro outro commands - - ["--help"] -> - Error.exitWithOverview intro outro commands - - ["--version"] -> - do hPutStrLn stdout (V.toChars V.compiler) - Exit.exitSuccess - - command : chunks -> - do case List.find (\cmd -> toName cmd == command) commands of - Nothing -> - Error.exitWithUnknown command (map toName commands) - - Just (Command _ _ details example args_ flags_ callback) -> - if elem "--help" chunks then - Error.exitWithHelp (Just command) details example args_ flags_ - - else - case snd $ Chomp.chomp Nothing chunks args_ flags_ of - Right (argsValue, flagsValue) -> - callback argsValue flagsValue - - Left err -> - Error.exitWithError err - - - --- AUTO-COMPLETE - - -_maybeAutoComplete :: [String] -> (Int -> [String] -> IO [String]) -> IO () -_maybeAutoComplete argStrings getSuggestions = - if length argStrings /= 3 then - return () - else - do maybeLine <- Env.lookupEnv "COMP_LINE" - case maybeLine of - Nothing -> - return () - - Just line -> - do (index, chunks) <- getCompIndex line - suggestions <- getSuggestions index chunks - hPutStr stdout (unlines suggestions) - Exit.exitFailure - - -getCompIndex :: String -> IO (Int, [String]) -getCompIndex line = - do maybePoint <- Env.lookupEnv "COMP_POINT" - case Read.readMaybe =<< maybePoint of - Nothing -> - do let chunks = words line - return (length chunks, chunks) - - Just point -> - let - groups = List.groupBy grouper (zip line [0..]) - rawChunks = drop 1 (filter (all (not . isSpace . fst)) groups) - in - return - ( findIndex 1 point rawChunks - , map (map fst) rawChunks - ) - - -grouper :: (Char, Int) -> (Char, Int) -> Bool -grouper (c1, _) (c2, _) = - isSpace c1 == isSpace c2 - - -isSpace :: Char -> Bool -isSpace char = - char == ' ' || char == '\t' || char == '\n' - - -findIndex :: Int -> Int -> [[(Char,Int)]] -> Int -findIndex index point chunks = - case chunks of - [] -> - index - - chunk:cs -> - let - lo = snd (head chunk) - hi = snd (last chunk) - in - if point < lo then - 0 - else if point <= hi + 1 then - index - else - findIndex (index + 1) point cs - - -_complexSuggest :: [Command] -> Int -> [String] -> IO [String] -_complexSuggest commands index strings = - case strings of - [] -> - return (map toName commands) - - command : chunks -> - if index == 1 then - return (filter (List.isPrefixOf command) (map toName commands)) - else - case List.find (\cmd -> toName cmd == command) commands of - Nothing -> - return [] - - Just (Command _ _ _ _ args_ flags_ _) -> - fst $ Chomp.chomp (Just (index-1)) chunks args_ flags_ - - - --- FLAGS - - -{-|-} -noFlags :: Flags () -noFlags = - FDone () - - -{-|-} -flags :: a -> Flags a -flags = - FDone - - -{-|-} -(|--) :: Flags (a -> b) -> Flag a -> Flags b -(|--) = - FMore - - - --- FLAG - - -{-|-} -flag :: String -> Parser a -> String -> Flag (Maybe a) -flag = - Flag - - -{-|-} -onOff :: String -> String -> Flag Bool -onOff = - OnOff - - - --- FANCY ARGS - - -{-|-} -args :: a -> RequiredArgs a -args = - Done - - -{-|-} -exactly :: RequiredArgs a -> Args a -exactly requiredArgs = - Args [Exactly requiredArgs] - - -{-|-} -(!) :: RequiredArgs (a -> b) -> Parser a -> RequiredArgs b -(!) = - Required - - -{-|-} -(?) :: RequiredArgs (Maybe a -> b) -> Parser a -> Args b -(?) requiredArgs optionalArg = - Args [Optional requiredArgs optionalArg] - - -{-|-} -(...) :: RequiredArgs ([a] -> b) -> Parser a -> Args b -(...) requiredArgs repeatedArg = - Args [Multiple requiredArgs repeatedArg] - - -{-|-} -oneOf :: [Args a] -> Args a -oneOf listOfArgs = - Args (concatMap (\(Args a) -> a) listOfArgs) - - - --- SIMPLE ARGS - - -{-|-} -noArgs :: Args () -noArgs = - exactly (args ()) - - -{-|-} -required :: Parser a -> Args a -required parser = - require1 id parser - - -{-|-} -optional :: Parser a -> Args (Maybe a) -optional parser = - args id ? parser - - -{-|-} -zeroOrMore :: Parser a -> Args [a] -zeroOrMore parser = - args id ... parser - - -{-|-} -oneOrMore :: Parser a -> Args (a, [a]) -oneOrMore parser = - args (,) ! parser ... parser - - -{-|-} -require0 :: args -> Args args -require0 value = - exactly (args value) - - -{-|-} -require1 :: (a -> args) -> Parser a -> Args args -require1 func a = - exactly (args func ! a) - - -{-|-} -require2 :: (a -> b -> args) -> Parser a -> Parser b -> Args args -require2 func a b = - exactly (args func ! a ! b) - - -{-|-} -require3 :: (a -> b -> c -> args) -> Parser a -> Parser b -> Parser c -> Args args -require3 func a b c = - exactly (args func ! a ! b ! c) - - -{-|-} -require4 :: (a -> b -> c -> d -> args) -> Parser a -> Parser b -> Parser c -> Parser d -> Args args -require4 func a b c d = - exactly (args func ! a ! b ! c ! d) - - -{-|-} -require5 :: (a -> b -> c -> d -> e -> args) -> Parser a -> Parser b -> Parser c -> Parser d -> Parser e -> Args args -require5 func a b c d e = - exactly (args func ! a ! b ! c ! d ! e) - - - --- SUGGEST FILES - - -{-| Helper for creating custom `Parser` values. It will suggest directories and -file names: - - suggestFiles [] -- suggests any file - suggestFiles ["elm"] -- suggests only .elm files - suggestFiles ["js","html"] -- suggests only .js and .html files - -Notice that you can limit the suggestion by the file extension! If you need -something more elaborate, you can implement a function like this yourself that -does whatever you need! --} -_suggestFiles :: [String] -> String -> IO [String] -_suggestFiles extensions string = - let - (dir, start) = - FP.splitFileName string - in - do content <- Dir.getDirectoryContents dir - Maybe.catMaybes - <$> traverse (isPossibleSuggestion extensions start dir) content - - -isPossibleSuggestion :: [String] -> String -> FilePath -> FilePath -> IO (Maybe FilePath) -isPossibleSuggestion extensions start dir path = - if List.isPrefixOf start path then - do isDir <- Dir.doesDirectoryExist (dir path) - return $ - if isDir then - Just (path ++ "/") - else if isOkayExtension path extensions then - Just path - else - Nothing - else - return Nothing - - -isOkayExtension :: FilePath -> [String] -> Bool -isOkayExtension path extensions = - null extensions || elem (FP.takeExtension path) extensions - diff --git a/terminal/impl/Terminal/Chomp.hs b/terminal/impl/Terminal/Chomp.hs deleted file mode 100644 index 692a7b0e98..0000000000 --- a/terminal/impl/Terminal/Chomp.hs +++ /dev/null @@ -1,514 +0,0 @@ -{-# LANGUAGE GADTs, Rank2Types #-} -module Terminal.Chomp - ( chomp - ) - where - - -import qualified Data.List as List - -import Terminal.Error -import Terminal.Internal - - - --- CHOMP INTERFACE - - -chomp :: Maybe Int -> [String] -> Args args -> Flags flags -> ( IO [String], Either Error (args, flags) ) -chomp maybeIndex strings args flags = - let - (Chomper flagChomper) = - chompFlags flags - - ok suggest chunks flagValue = - fmap (flip (,) flagValue) <$> chompArgs suggest chunks args - - err suggest flagError = - ( addSuggest (return []) suggest, Left (BadFlag flagError) ) - in - flagChomper (toSuggest maybeIndex) (toChunks strings) ok err - - -toChunks :: [String] -> [Chunk] -toChunks strings = - zipWith Chunk [ 1 .. length strings ] strings - - -toSuggest :: Maybe Int -> Suggest -toSuggest maybeIndex = - case maybeIndex of - Nothing -> - NoSuggestion - - Just index -> - Suggest index - - - --- CHOMPER - - -newtype Chomper x a = - Chomper ( - forall result. - Suggest - -> [Chunk] - -> (Suggest -> [Chunk] -> a -> result) - -> (Suggest -> x -> result) - -> result - ) - - -data Chunk = - Chunk - { _index :: Int - , _chunk :: String - } - - -data Suggest - = NoSuggestion - | Suggest Int - | Suggestions (IO [String]) - - -makeSuggestion :: Suggest -> (Int -> Maybe (IO [String])) -> Suggest -makeSuggestion suggest maybeUpdate = - case suggest of - NoSuggestion -> - suggest - - Suggestions _ -> - suggest - - Suggest index -> - maybe suggest Suggestions (maybeUpdate index) - - - --- ARGS - - -chompArgs :: Suggest -> [Chunk] -> Args a -> (IO [String], Either Error a) -chompArgs suggest chunks (Args completeArgsList) = - chompArgsHelp suggest chunks completeArgsList [] [] - - -chompArgsHelp :: Suggest -> [Chunk] -> [CompleteArgs a] -> [Suggest] -> [(CompleteArgs a, ArgError)] -> (IO [String], Either Error a) -chompArgsHelp suggest chunks completeArgsList revSuggest revArgErrors = - case completeArgsList of - [] -> - ( foldl addSuggest (return []) revSuggest - , Left (BadArgs (reverse revArgErrors)) - ) - - completeArgs : others -> - case chompCompleteArgs suggest chunks completeArgs of - (s1, Left argError) -> - chompArgsHelp suggest chunks others (s1:revSuggest) ((completeArgs,argError):revArgErrors) - - (s1, Right value) -> - ( addSuggest (return []) s1 - , Right value - ) - - -addSuggest :: IO [String] -> Suggest -> IO [String] -addSuggest everything suggest = - case suggest of - NoSuggestion -> - everything - - Suggest _ -> - everything - - Suggestions newStuff -> - (++) <$> newStuff <*> everything - - - --- COMPLETE ARGS - - -chompCompleteArgs :: Suggest -> [Chunk] -> CompleteArgs a -> (Suggest, Either ArgError a) -chompCompleteArgs suggest chunks completeArgs = - let - numChunks = length chunks - in - case completeArgs of - Exactly requiredArgs -> - chompExactly suggest chunks (chompRequiredArgs numChunks requiredArgs) - - Optional requiredArgs parser -> - chompOptional suggest chunks (chompRequiredArgs numChunks requiredArgs) parser - - Multiple requiredArgs parser -> - chompMultiple suggest chunks (chompRequiredArgs numChunks requiredArgs) parser - - -chompExactly :: Suggest -> [Chunk] -> Chomper ArgError a -> (Suggest, Either ArgError a) -chompExactly suggest chunks (Chomper chomper) = - let - ok s cs value = - case map _chunk cs of - [] -> (s, Right value) - es -> (s, Left (ArgExtras es)) - - err s argError = - (s, Left argError) - in - chomper suggest chunks ok err - - -chompOptional :: Suggest -> [Chunk] -> Chomper ArgError (Maybe a -> b) -> Parser a -> (Suggest, Either ArgError b) -chompOptional suggest chunks (Chomper chomper) parser = - let - ok s1 cs func = - case cs of - [] -> - (s1, Right (func Nothing)) - - Chunk index string : others -> - case tryToParse s1 parser index string of - (s2, Left expectation) -> - (s2, Left (ArgBad string expectation)) - - (s2, Right value) -> - case map _chunk others of - [] -> (s2, Right (func (Just value))) - es -> (s2, Left (ArgExtras es)) - - err s1 argError = - (s1, Left argError) - in - chomper suggest chunks ok err - - -chompMultiple :: Suggest -> [Chunk] -> Chomper ArgError ([a] -> b) -> Parser a -> (Suggest, Either ArgError b) -chompMultiple suggest chunks (Chomper chomper) parser = - let - err s1 argError = - (s1, Left argError) - in - chomper suggest chunks (chompMultipleHelp parser []) err - - -chompMultipleHelp :: Parser a -> [a] -> Suggest -> [Chunk] -> ([a] -> b) -> (Suggest, Either ArgError b) -chompMultipleHelp parser revArgs suggest chunks func = - case chunks of - [] -> - (suggest, Right (func (reverse revArgs))) - - Chunk index string : otherChunks -> - case tryToParse suggest parser index string of - (s1, Left expectation) -> - (s1, Left (ArgBad string expectation)) - - (s1, Right arg) -> - chompMultipleHelp parser (arg:revArgs) s1 otherChunks func - - - --- REQUIRED ARGS - - -chompRequiredArgs :: Int -> RequiredArgs a -> Chomper ArgError a -chompRequiredArgs numChunks args = - case args of - Done value -> - return value - - Required funcArgs argParser -> - do func <- chompRequiredArgs numChunks funcArgs - arg <- chompArg numChunks argParser - return (func arg) - - -chompArg :: Int -> Parser a -> Chomper ArgError a -chompArg numChunks parser@(Parser singular _ _ _ toExamples) = - Chomper $ \suggest chunks ok err -> - case chunks of - [] -> - let - newSuggest = makeSuggestion suggest (suggestArg parser numChunks) - theError = ArgMissing (Expectation singular (toExamples "")) - in - err newSuggest theError - - Chunk index string : otherChunks -> - case tryToParse suggest parser index string of - (newSuggest, Left expectation) -> - err newSuggest (ArgBad string expectation) - - (newSuggest, Right arg) -> - ok newSuggest otherChunks arg - - -suggestArg :: Parser a -> Int -> Int -> Maybe (IO [String]) -suggestArg (Parser _ _ _ toSuggestions _) numChunks targetIndex = - if numChunks <= targetIndex then - Just (toSuggestions "") - else - Nothing - - - --- PARSER - - -tryToParse :: Suggest -> Parser a -> Int -> String -> (Suggest, Either Expectation a) -tryToParse suggest (Parser singular _ parse toSuggestions toExamples) index string = - let - newSuggest = - makeSuggestion suggest $ \targetIndex -> - if index == targetIndex then Just (toSuggestions string) else Nothing - - outcome = - case parse string of - Nothing -> - Left (Expectation singular (toExamples string)) - - Just value -> - Right value - in - (newSuggest, outcome) - - - --- FLAGS - - -chompFlags :: Flags a -> Chomper FlagError a -chompFlags flags = - do value <- chompFlagsHelp flags - checkForUnknownFlags flags - return value - - -chompFlagsHelp :: Flags a -> Chomper FlagError a -chompFlagsHelp flags = - case flags of - FDone value -> - return value - - FMore funcFlags argFlag -> - do func <- chompFlagsHelp funcFlags - arg <- chompFlag argFlag - return (func arg) - - - --- FLAG - - -chompFlag :: Flag a -> Chomper FlagError a -chompFlag flag = - case flag of - OnOff flagName _ -> - chompOnOffFlag flagName - - Flag flagName parser _ -> - chompNormalFlag flagName parser - - -chompOnOffFlag :: String -> Chomper FlagError Bool -chompOnOffFlag flagName = - Chomper $ \suggest chunks ok err -> - case findFlag flagName chunks of - Nothing -> - ok suggest chunks False - - Just (FoundFlag before value after) -> - case value of - DefNope -> - ok suggest (before ++ after) True - - Possibly chunk -> - ok suggest (before ++ chunk : after) True - - Definitely _ string -> - err suggest (FlagWithValue flagName string) - - -chompNormalFlag :: String -> Parser a -> Chomper FlagError (Maybe a) -chompNormalFlag flagName parser@(Parser singular _ _ _ toExamples) = - Chomper $ \suggest chunks ok err -> - case findFlag flagName chunks of - Nothing -> - ok suggest chunks Nothing - - Just (FoundFlag before value after) -> - let - attempt index string = - case tryToParse suggest parser index string of - (newSuggest, Left expectation) -> - err newSuggest (FlagWithBadValue flagName string expectation) - - (newSuggest, Right flagValue) -> - ok newSuggest (before ++ after) (Just flagValue) - in - case value of - Definitely index string -> - attempt index string - - Possibly (Chunk index string) -> - attempt index string - - DefNope -> - err suggest (FlagWithNoValue flagName (Expectation singular (toExamples ""))) - - - --- FIND FLAG - - -data FoundFlag = - FoundFlag - { _before :: [Chunk] - , _value :: Value - , _after :: [Chunk] - } - - -data Value - = Definitely Int String - | Possibly Chunk - | DefNope - - -findFlag :: String -> [Chunk] -> Maybe FoundFlag -findFlag flagName chunks = - findFlagHelp [] ("--" ++ flagName) ("--" ++ flagName ++ "=") chunks - - -findFlagHelp :: [Chunk] -> String -> String -> [Chunk] -> Maybe FoundFlag -findFlagHelp revPrev loneFlag flagPrefix chunks = - let - succeed value after = - Just (FoundFlag (reverse revPrev) value after) - - deprefix string = - drop (length flagPrefix) string - in - case chunks of - [] -> - Nothing - - chunk@(Chunk index string) : rest -> - if List.isPrefixOf flagPrefix string then - succeed (Definitely index (deprefix string)) rest - - else if string /= loneFlag then - findFlagHelp (chunk:revPrev) loneFlag flagPrefix rest - - else - case rest of - [] -> - succeed DefNope [] - - argChunk@(Chunk _ potentialArg) : restOfRest -> - if List.isPrefixOf "-" potentialArg then - succeed DefNope rest - else - succeed (Possibly argChunk) restOfRest - - - --- CHECK FOR UNKNOWN FLAGS - - -checkForUnknownFlags :: Flags a -> Chomper FlagError () -checkForUnknownFlags flags = - Chomper $ \suggest chunks ok err -> - case filter startsWithDash chunks of - [] -> - ok suggest chunks () - - unknownFlags@(Chunk _ unknownFlag : _) -> - err - (makeSuggestion suggest (suggestFlag unknownFlags flags)) - (FlagUnknown unknownFlag flags) - - -suggestFlag :: [Chunk] -> Flags a -> Int -> Maybe (IO [String]) -suggestFlag unknownFlags flags targetIndex = - case unknownFlags of - [] -> - Nothing - - Chunk index string : otherUnknownFlags -> - if index == targetIndex then - Just (return (filter (List.isPrefixOf string) (getFlagNames flags []))) - else - suggestFlag otherUnknownFlags flags targetIndex - - -startsWithDash :: Chunk -> Bool -startsWithDash (Chunk _ string) = - List.isPrefixOf "-" string - - -getFlagNames :: Flags a -> [String] -> [String] -getFlagNames flags names = - case flags of - FDone _ -> - "--help" : names - - FMore subFlags flag -> - getFlagNames subFlags (getFlagName flag : names) - - -getFlagName :: Flag a -> String -getFlagName flag = - case flag of - Flag name _ _ -> - "--" ++ name - - OnOff name _ -> - "--" ++ name - - - --- CHOMPER INSTANCES - - -instance Functor (Chomper x) where - fmap func (Chomper chomper) = - Chomper $ \i w ok err -> - let - ok1 s1 cs1 value = - ok s1 cs1 (func value) - in - chomper i w ok1 err - - -instance Applicative (Chomper x) where - pure value = - Chomper $ \ss cs ok _ -> - ok ss cs value - - (<*>) (Chomper funcChomper) (Chomper argChomper) = - Chomper $ \s cs ok err -> - let - ok1 s1 cs1 func = - let - ok2 s2 cs2 value = - ok s2 cs2 (func value) - in - argChomper s1 cs1 ok2 err - in - funcChomper s cs ok1 err - - -instance Monad (Chomper x) where - return = pure - - (>>=) (Chomper aChomper) callback = - Chomper $ \s cs ok err -> - let - ok1 s1 cs1 a = - case callback a of - Chomper bChomper -> bChomper s1 cs1 ok err - in - aChomper s cs ok1 err diff --git a/terminal/impl/Terminal/Error.hs b/terminal/impl/Terminal/Error.hs deleted file mode 100644 index 44f0838ab1..0000000000 --- a/terminal/impl/Terminal/Error.hs +++ /dev/null @@ -1,457 +0,0 @@ -{-# LANGUAGE GADTs, OverloadedStrings #-} -module Terminal.Error - ( Error(..) - , ArgError(..) - , FlagError(..) - , Expectation(..) - , exitWithHelp - , exitWithError - , exitWithUnknown - , exitWithOverview - ) - where - - -import Data.Monoid ((<>)) -import qualified Data.List as List -import qualified Data.Maybe as Maybe -import GHC.IO.Handle (hIsTerminalDevice) -import qualified System.Environment as Env -import qualified System.Exit as Exit -import qualified System.FilePath as FP -import System.IO (hPutStrLn, stderr) -import qualified Text.PrettyPrint.ANSI.Leijen as P - -import Reporting.Suggest as Suggest -import Terminal.Internal - - - --- ERROR - - -data Error where - BadArgs :: [(CompleteArgs a, ArgError)] -> Error - BadFlag :: FlagError -> Error - - -data ArgError - = ArgMissing Expectation - | ArgBad String Expectation - | ArgExtras [String] - - -data FlagError where - FlagWithValue :: String -> String -> FlagError - FlagWithBadValue :: String -> String -> Expectation -> FlagError - FlagWithNoValue :: String -> Expectation -> FlagError - FlagUnknown :: String -> Flags a -> FlagError - - -data Expectation = - Expectation - { _type :: String - , _examples :: IO [String] - } - - - --- EXIT - - -exitSuccess :: [P.Doc] -> IO a -exitSuccess = - exitWith Exit.ExitSuccess - - -exitFailure :: [P.Doc] -> IO a -exitFailure = - exitWith (Exit.ExitFailure 1) - - -exitWith :: Exit.ExitCode -> [P.Doc] -> IO a -exitWith code docs = - do isTerminal <- hIsTerminalDevice stderr - let adjust = if isTerminal then id else P.plain - P.displayIO stderr $ P.renderPretty 1 80 $ - adjust $ P.vcat $ concatMap (\d -> [d,""]) docs - hPutStrLn stderr "" - Exit.exitWith code - - -getExeName :: IO String -getExeName = - FP.takeFileName <$> Env.getProgName - - -stack :: [P.Doc] -> P.Doc -stack docs = - P.vcat $ List.intersperse "" docs - - -reflow :: String -> P.Doc -reflow string = - P.fillSep $ map P.text $ words string - - - --- HELP - - -exitWithHelp :: Maybe String -> String -> P.Doc -> Args args -> Flags flags -> IO a -exitWithHelp maybeCommand details example (Args args) flags = - do command <- toCommand maybeCommand - exitSuccess $ - [ reflow details - , P.indent 4 $ P.cyan $ P.vcat $ map (argsToDoc command) args - , example - ] - ++ - case flagsToDocs flags [] of - [] -> - [] - - docs@(_:_) -> - [ "You can customize this command with the following flags:" - , P.indent 4 $ stack docs - ] - - -toCommand :: Maybe String -> IO String -toCommand maybeCommand = - do exeName <- getExeName - return $ - case maybeCommand of - Nothing -> - exeName - - Just command -> - exeName ++ " " ++ command - - -argsToDoc :: String -> CompleteArgs a -> P.Doc -argsToDoc command args = - case args of - Exactly required -> - argsToDocHelp command required [] - - Multiple required (Parser _ plural _ _ _) -> - argsToDocHelp command required ["zero or more " ++ plural] - - Optional required (Parser singular _ _ _ _) -> - argsToDocHelp command required ["optional " ++ singular] - - -argsToDocHelp :: String -> RequiredArgs a -> [String] -> P.Doc -argsToDocHelp command args names = - case args of - Done _ -> - P.hang 4 $ P.hsep $ map P.text $ - command : map toToken names - - Required others (Parser singular _ _ _ _) -> - argsToDocHelp command others (singular : names) - - -toToken :: String -> String -toToken string = - "<" ++ map (\c -> if c == ' ' then '-' else c) string ++ ">" - - -flagsToDocs :: Flags flags -> [P.Doc] -> [P.Doc] -flagsToDocs flags docs = - case flags of - FDone _ -> - docs - - FMore more flag -> - let - flagDoc = - P.vcat $ - case flag of - Flag name (Parser singular _ _ _ _) description -> - [ P.dullcyan $ P.text $ "--" ++ name ++ "=" ++ toToken singular - , P.indent 4 $ reflow description - ] - - OnOff name description -> - [ P.dullcyan $ P.text $ "--" ++ name - , P.indent 4 $ reflow description - ] - in - flagsToDocs more (flagDoc:docs) - - - --- OVERVIEW - - -exitWithOverview :: P.Doc -> P.Doc -> [Command] -> IO a -exitWithOverview intro outro commands = - do exeName <- getExeName - exitSuccess - [ intro - , "The most common commands are:" - , P.indent 4 $ stack $ Maybe.mapMaybe (toSummary exeName) commands - , "There are a bunch of other commands as well though. Here is a full list:" - , P.indent 4 $ P.dullcyan $ toCommandList exeName commands - , "Adding the --help flag gives a bunch of additional details about each one." - , outro - ] - - -toSummary :: String -> Command -> Maybe P.Doc -toSummary exeName (Command name summary _ _ (Args args) _ _) = - case summary of - Uncommon -> - Nothing - - Common summaryString -> - Just $ - P.vcat - [ P.cyan $ argsToDoc (exeName ++ " " ++ name) (head args) - , P.indent 4 $ reflow summaryString - ] - - -toCommandList :: String -> [Command] -> P.Doc -toCommandList exeName commands = - let - names = map toName commands - width = maximum (map length names) - - toExample name = - P.text $ exeName ++ " " ++ name ++ replicate (width - length name) ' ' ++ " --help" - in - P.vcat (map toExample names) - - - --- UNKNOWN - - -exitWithUnknown :: String -> [String] -> IO a -exitWithUnknown unknown knowns = - let - nearbyKnowns = - takeWhile (\(r,_) -> r <= 3) (Suggest.rank unknown id knowns) - - suggestions = - case map toGreen (map snd nearbyKnowns) of - [] -> - [] - - [nearby] -> - ["Try",nearby,"instead?"] - - [a,b] -> - ["Try",a,"or",b,"instead?"] - - abcs@(_:_:_:_) -> - ["Try"] ++ map (<> ",") (init abcs) ++ ["or",last abcs,"instead?"] - in - do exeName <- getExeName - exitFailure - [ P.fillSep $ ["There","is","no",toRed unknown,"command."] ++ suggestions - , reflow $ "Run `" ++ exeName ++ "` with no arguments to get more hints." - ] - - - --- ERROR TO DOC - - -exitWithError :: Error -> IO a -exitWithError err = - exitFailure =<< - case err of - BadFlag flagError -> - flagErrorToDocs flagError - - BadArgs argErrors -> - case argErrors of - [] -> - return - [ reflow $ "I was not expecting any arguments for this command." - , reflow $ "Try removing them?" - ] - - [(_args, argError)] -> - argErrorToDocs argError - - _:_:_ -> - argErrorToDocs $ head $ List.sortOn toArgErrorRank (map snd argErrors) - - -toArgErrorRank :: ArgError -> Int -- lower is better -toArgErrorRank err = - case err of - ArgBad _ _ -> 0 - ArgMissing _ -> 1 - ArgExtras _ -> 2 - - -toGreen :: String -> P.Doc -toGreen str = - P.green (P.text str) - - -toYellow :: String -> P.Doc -toYellow str = - P.yellow (P.text str) - - -toRed :: String -> P.Doc -toRed str = - P.red (P.text str) - - - --- ARG ERROR TO DOC - - -argErrorToDocs :: ArgError -> IO [P.Doc] -argErrorToDocs argError = - case argError of - ArgMissing (Expectation tipe makeExamples) -> - do examples <- makeExamples - return - [ P.fillSep - ["The","arguments","you","have","are","fine,","but","in","addition,","I","was" - ,"expecting","a",toYellow (toToken tipe),"value.","For","example:" - ] - , P.indent 4 $ P.green $ P.vcat $ map P.text examples - ] - - ArgBad string (Expectation tipe makeExamples) -> - do examples <- makeExamples - return - [ "I am having trouble with this argument:" - , P.indent 4 $ toRed string - , P.fillSep $ - ["It","is","supposed","to","be","a" - ,toYellow (toToken tipe),"value,","like" - ] ++ if length examples == 1 then ["this:"] else ["one","of","these:"] - , P.indent 4 $ P.green $ P.vcat $ map P.text examples - ] - - ArgExtras extras -> - let - (these, them) = - case extras of - [_] -> ("this argument", "it") - _ -> ("these arguments", "them") - in - return - [ reflow $ "I was not expecting " ++ these ++ ":" - , P.indent 4 $ P.red $ P.vcat $ map P.text extras - , reflow $ "Try removing " ++ them ++ "?" - ] - - - --- FLAG ERROR TO DOC - - -flagErrorHelp :: String -> String -> [P.Doc] -> IO [P.Doc] -flagErrorHelp summary original explanation = - return $ - [ reflow summary - , P.indent 4 (toRed original) - ] - ++ explanation - - -flagErrorToDocs :: FlagError -> IO [P.Doc] -flagErrorToDocs flagError = - case flagError of - FlagWithValue flagName value -> - flagErrorHelp - "This on/off flag was given a value:" - ("--" ++ flagName ++ "=" ++ value) - [ "An on/off flag either exists or not. It cannot have an equals sign and value.\n\ - \Maybe you want this instead?" - , P.indent 4 $ toGreen $ "--" ++ flagName - ] - - FlagWithNoValue flagName (Expectation tipe makeExamples) -> - do examples <- makeExamples - flagErrorHelp - "This flag needs more information:" - ("--" ++ flagName) - [ P.fillSep ["It","needs","a",toYellow (toToken tipe),"like","this:"] - , P.indent 4 $ P.vcat $ map toGreen $ - case take 4 examples of - [] -> - ["--" ++ flagName ++ "=" ++ toToken tipe] - - _:_ -> - map (\example -> "--" ++ flagName ++ "=" ++ example) examples - ] - - FlagWithBadValue flagName badValue (Expectation tipe makeExamples) -> - do examples <- makeExamples - flagErrorHelp - "This flag was given a bad value:" - ("--" ++ flagName ++ "=" ++ badValue) - [ P.fillSep $ - ["I","need","a","valid",toYellow (toToken tipe),"value.","For","example:" - ] - , P.indent 4 $ P.vcat $ map toGreen $ - case take 4 examples of - [] -> - ["--" ++ flagName ++ "=" ++ toToken tipe] - - _:_ -> - map (\example -> "--" ++ flagName ++ "=" ++ example) examples - ] - - FlagUnknown unknown flags -> - flagErrorHelp - "I do not recognize this flag:" - unknown - ( - let unknownName = takeWhile ('=' /=) (dropWhile ('-' ==) unknown) in - case getNearbyFlags unknownName flags [] of - [] -> - [] - - [thisOne] -> - [ P.fillSep ["Maybe","you","want",P.green thisOne,"instead?"] - ] - - suggestions -> - [ P.fillSep ["Maybe","you","want","one","of","these","instead?"] - , P.indent 4 $ P.green $ P.vcat suggestions - ] - ) - - -getNearbyFlags :: String -> Flags a -> [(Int, String)] -> [P.Doc] -getNearbyFlags unknown flags unsortedFlags = - case flags of - FMore more flag -> - getNearbyFlags unknown more (getNearbyFlagsHelp unknown flag : unsortedFlags) - - FDone _ -> - map P.text $ map snd $ List.sortOn fst $ - case filter (\(d,_) -> d < 3) unsortedFlags of - [] -> - unsortedFlags - - nearbyUnsortedFlags -> - nearbyUnsortedFlags - - -getNearbyFlagsHelp :: String -> Flag a -> (Int, String) -getNearbyFlagsHelp unknown flag = - case flag of - OnOff flagName _ -> - ( Suggest.distance unknown flagName - , "--" ++ flagName - ) - - Flag flagName (Parser singular _ _ _ _) _ -> - ( Suggest.distance unknown flagName - , "--" ++ flagName ++ "=" ++ toToken singular - ) diff --git a/terminal/impl/Terminal/Helpers.hs b/terminal/impl/Terminal/Helpers.hs deleted file mode 100644 index cb7b716fab..0000000000 --- a/terminal/impl/Terminal/Helpers.hs +++ /dev/null @@ -1,148 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module Terminal.Helpers - ( version - , elmFile - , package - ) - where - - -import qualified Data.ByteString.UTF8 as BS_UTF8 -import qualified Data.Char as Char -import qualified Data.List as List -import qualified Data.Map as Map -import qualified Data.Utf8 as Utf8 -import qualified System.FilePath as FP - -import Terminal (Parser(..)) -import qualified Deps.Registry as Registry -import qualified Elm.Package as Pkg -import qualified Elm.Version as V -import qualified Parse.Primitives as P -import qualified Stuff -import qualified Reporting.Suggest as Suggest - - - --- VERSION - - -version :: Parser V.Version -version = - Parser - { _singular = "version" - , _plural = "versions" - , _parser = parseVersion - , _suggest = suggestVersion - , _examples = return . exampleVersions - } - - -parseVersion :: String -> Maybe V.Version -parseVersion chars = - case P.fromByteString V.parser (,) (BS_UTF8.fromString chars) of - Right vsn -> Just vsn - Left _ -> Nothing - - -suggestVersion :: String -> IO [String] -suggestVersion _ = - return [] - - -exampleVersions :: String -> [String] -exampleVersions chars = - let - chunks = map Utf8.toChars (Utf8.split 0x2E {-.-} (Utf8.fromChars chars)) - isNumber cs = not (null cs) && all Char.isDigit cs - in - if all isNumber chunks then - case chunks of - [x] -> [ x ++ ".0.0" ] - [x,y] -> [ x ++ "." ++ y ++ ".0" ] - x:y:z:_ -> [ x ++ "." ++ y ++ "." ++ z ] - _ -> ["1.0.0", "2.0.3"] - - else - ["1.0.0", "2.0.3"] - - - --- ELM FILE - - -elmFile :: Parser FilePath -elmFile = - Parser - { _singular = "elm file" - , _plural = "elm files" - , _parser = parseElmFile - , _suggest = \_ -> return [] - , _examples = exampleElmFiles - } - - -parseElmFile :: String -> Maybe FilePath -parseElmFile chars = - if FP.takeExtension chars == ".elm" then - Just chars - else - Nothing - - -exampleElmFiles :: String -> IO [String] -exampleElmFiles _ = - return ["Main.elm","src/Main.elm"] - - - --- PACKAGE - - -package :: Parser Pkg.Name -package = - Parser - { _singular = "package" - , _plural = "packages" - , _parser = parsePackage - , _suggest = suggestPackages - , _examples = examplePackages - } - - -parsePackage :: String -> Maybe Pkg.Name -parsePackage chars = - case P.fromByteString Pkg.parser (,) (BS_UTF8.fromString chars) of - Right pkg -> Just pkg - Left _ -> Nothing - - -suggestPackages :: String -> IO [String] -suggestPackages given = - do cache <- Stuff.getPackageCache - maybeRegistry <- Registry.read cache - return $ - case maybeRegistry of - Nothing -> - [] - - Just (Registry.Registry _ versions) -> - filter (List.isPrefixOf given) $ - map Pkg.toChars (Map.keys versions) - - -examplePackages :: String -> IO [String] -examplePackages given = - do cache <- Stuff.getPackageCache - maybeRegistry <- Registry.read cache - return $ - case maybeRegistry of - Nothing -> - [ "elm/json" - , "elm/http" - , "elm/random" - ] - - Just (Registry.Registry _ versions) -> - map Pkg.toChars $ take 4 $ - Suggest.sort given Pkg.toChars (Map.keys versions) diff --git a/terminal/impl/Terminal/Internal.hs b/terminal/impl/Terminal/Internal.hs deleted file mode 100644 index 3c847a029d..0000000000 --- a/terminal/impl/Terminal/Internal.hs +++ /dev/null @@ -1,93 +0,0 @@ -{-# LANGUAGE GADTs #-} -module Terminal.Internal - ( Command(..) - , toName - , Summary(..) - , Flags(..) - , Flag(..) - , Parser(..) - , Args(..) - , CompleteArgs(..) - , RequiredArgs(..) - ) - where - - -import Text.PrettyPrint.ANSI.Leijen (Doc) - - - --- COMMAND - - -data Command where - Command - :: String - -> Summary - -> String - -> Doc - -> Args args - -> Flags flags - -> (args -> flags -> IO ()) - -> Command - - -toName :: Command -> String -toName (Command name _ _ _ _ _ _) = - name - - - -{-| The information that shows when you run the executable with no arguments. -If you say it is `Common`, you need to tell people what it does. Try to keep -it to two or three lines. If you say it is `Uncommon` you can rely on `Details` -for a more complete explanation. --} -data Summary = Common String | Uncommon - - - --- FLAGS - - -data Flags a where - FDone :: a -> Flags a - FMore :: Flags (a -> b) -> Flag a -> Flags b - - -data Flag a where - Flag :: String -> Parser a -> String -> Flag (Maybe a) - OnOff :: String -> String -> Flag Bool - - - --- PARSERS - - -data Parser a = - Parser - { _singular :: String - , _plural :: String - , _parser :: String -> Maybe a - , _suggest :: String -> IO [String] - , _examples :: String -> IO [String] - } - - - --- ARGS - - -newtype Args a = - Args [CompleteArgs a] - - -data CompleteArgs args where - Exactly :: RequiredArgs args -> CompleteArgs args - Multiple :: RequiredArgs ([a] -> args) -> Parser a -> CompleteArgs args - Optional :: RequiredArgs (Maybe a -> args) -> Parser a -> CompleteArgs args - - -data RequiredArgs a where - Done :: a -> RequiredArgs a - Required :: RequiredArgs (a -> b) -> Parser a -> RequiredArgs b diff --git a/terminal/src/Bump.hs b/terminal/src/Bump.hs deleted file mode 100644 index d65f7c4de2..0000000000 --- a/terminal/src/Bump.hs +++ /dev/null @@ -1,169 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module Bump - ( run - ) - where - - -import qualified Data.List as List -import qualified Data.NonEmptyList as NE - -import qualified BackgroundWriter as BW -import qualified Build -import qualified Deps.Bump as Bump -import qualified Deps.Diff as Diff -import qualified Deps.Registry as Registry -import qualified Elm.Details as Details -import qualified Elm.Docs as Docs -import qualified Elm.Magnitude as M -import qualified Elm.Outline as Outline -import qualified Elm.Version as V -import qualified Http -import Reporting.Doc ((<>), (<+>)) -import qualified Reporting -import qualified Reporting.Doc as D -import qualified Reporting.Exit as Exit -import qualified Reporting.Exit.Help as Help -import qualified Reporting.Task as Task -import qualified Stuff - - - --- RUN - - -run :: () -> () -> IO () -run () () = - Reporting.attempt Exit.bumpToReport $ - Task.run (bump =<< getEnv) - - - --- ENV - - -data Env = - Env - { _root :: FilePath - , _cache :: Stuff.PackageCache - , _manager :: Http.Manager - , _registry :: Registry.Registry - , _outline :: Outline.PkgOutline - } - - -getEnv :: Task.Task Exit.Bump Env -getEnv = - do maybeRoot <- Task.io $ Stuff.findRoot - case maybeRoot of - Nothing -> - Task.throw Exit.BumpNoOutline - - Just root -> - do cache <- Task.io $ Stuff.getPackageCache - manager <- Task.io $ Http.getManager - registry <- Task.eio Exit.BumpMustHaveLatestRegistry $ Registry.latest manager cache - outline <- Task.eio Exit.BumpBadOutline $ Outline.read root - case outline of - Outline.App _ -> - Task.throw Exit.BumpApplication - - Outline.Pkg pkgOutline -> - return $ Env root cache manager registry pkgOutline - - - --- BUMP - - -bump :: Env -> Task.Task Exit.Bump () -bump env@(Env root _ _ registry outline@(Outline.PkgOutline pkg _ _ vsn _ _ _ _)) = - case Registry.getVersions pkg registry of - Just knownVersions -> - let - bumpableVersions = - map (\(old, _, _) -> old) (Bump.getPossibilities knownVersions) - in - if elem vsn bumpableVersions - then suggestVersion env - else - Task.throw $ Exit.BumpUnexpectedVersion vsn $ - map head (List.group (List.sort bumpableVersions)) - - Nothing -> - Task.io $ checkNewPackage root outline - - - --- CHECK NEW PACKAGE - - -checkNewPackage :: FilePath -> Outline.PkgOutline -> IO () -checkNewPackage root outline@(Outline.PkgOutline _ _ _ version _ _ _ _) = - do putStrLn Exit.newPackageOverview - if version == V.one - then - putStrLn "The version number in elm.json is correct so you are all set!" - else - changeVersion root outline V.one $ - "It looks like the version in elm.json has been changed though!\n\ - \Would you like me to change it back to " - <> D.fromVersion V.one <> "? [Y/n] " - - - --- SUGGEST VERSION - - -suggestVersion :: Env -> Task.Task Exit.Bump () -suggestVersion (Env root cache manager _ outline@(Outline.PkgOutline pkg _ _ vsn _ _ _ _)) = - do oldDocs <- Task.eio (Exit.BumpCannotFindDocs pkg vsn) (Diff.getDocs cache manager pkg vsn) - newDocs <- generateDocs root outline - let changes = Diff.diff oldDocs newDocs - let newVersion = Diff.bump changes vsn - Task.io $ changeVersion root outline newVersion $ - let - old = D.fromVersion vsn - new = D.fromVersion newVersion - mag = D.fromChars $ M.toChars (Diff.toMagnitude changes) - in - "Based on your new API, this should be a" <+> D.green mag <+> "change (" <> old <> " => " <> new <> ")\n" - <> "Bail out of this command and run 'elm diff' for a full explanation.\n" - <> "\n" - <> "Should I perform the update (" <> old <> " => " <> new <> ") in elm.json? [Y/n] " - - -generateDocs :: FilePath -> Outline.PkgOutline -> Task.Task Exit.Bump Docs.Documentation -generateDocs root (Outline.PkgOutline _ _ _ _ exposed _ _ _) = - do details <- - Task.eio Exit.BumpBadDetails $ BW.withScope $ \scope -> - Details.load Reporting.silent scope root - - case Outline.flattenExposed exposed of - [] -> - Task.throw $ Exit.BumpNoExposed - - e:es -> - Task.eio Exit.BumpBadBuild $ - Build.fromExposed Reporting.silent root details Build.KeepDocs (NE.List e es) - - - --- CHANGE VERSION - - -changeVersion :: FilePath -> Outline.PkgOutline -> V.Version -> D.Doc -> IO () -changeVersion root outline targetVersion question = - do approved <- Reporting.ask question - if not approved - then - putStrLn "Okay, I did not change anything!" - - else - do Outline.write root $ Outline.Pkg $ - outline { Outline._pkg_version = targetVersion } - - Help.toStdout $ - "Version changed to " - <> D.green (D.fromVersion targetVersion) - <> "!\n" diff --git a/terminal/src/Develop.hs b/terminal/src/Develop.hs deleted file mode 100644 index 0033936471..0000000000 --- a/terminal/src/Develop.hs +++ /dev/null @@ -1,256 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module Develop - ( Flags(..) - , run - ) - where - - -import Control.Applicative ((<|>)) -import Control.Monad (guard) -import Control.Monad.Trans (MonadIO(liftIO)) -import qualified Data.ByteString.Builder as B -import qualified Data.ByteString as BS -import qualified Data.HashMap.Strict as HashMap -import Data.Monoid ((<>)) -import qualified Data.NonEmptyList as NE -import qualified System.Directory as Dir -import System.FilePath as FP -import Snap.Core hiding (path) -import Snap.Http.Server -import Snap.Util.FileServe - -import qualified BackgroundWriter as BW -import qualified Build -import qualified Elm.Details as Details -import qualified Develop.Generate.Help as Help -import qualified Develop.Generate.Index as Index -import qualified Develop.StaticFiles as StaticFiles -import qualified Generate.Html as Html -import qualified Generate -import qualified Reporting -import qualified Reporting.Exit as Exit -import qualified Reporting.Task as Task -import qualified Stuff - - - --- RUN THE DEV SERVER - - -data Flags = - Flags - { _port :: Maybe Int - } - - -run :: () -> Flags -> IO () -run () (Flags maybePort) = - do let port = maybe 8000 id maybePort - putStrLn $ "Go to http://localhost:" ++ show port ++ " to see your project dashboard." - httpServe (config port) $ - serveFiles - <|> serveDirectoryWith directoryConfig "." - <|> serveAssets - <|> error404 - - -config :: Int -> Config Snap a -config port = - setVerbose False $ setPort port $ - setAccessLog ConfigNoLog $ setErrorLog ConfigNoLog $ defaultConfig - - - --- INDEX - - -directoryConfig :: MonadSnap m => DirectoryConfig m -directoryConfig = - fancyDirectoryConfig - { indexFiles = [] - , indexGenerator = \pwd -> - do modifyResponse $ setContentType "text/html;charset=utf-8" - writeBuilder =<< liftIO (Index.generate pwd) - } - - - --- NOT FOUND - - -error404 :: Snap () -error404 = - do modifyResponse $ setResponseStatus 404 "Not Found" - modifyResponse $ setContentType "text/html;charset=utf-8" - writeBuilder $ Help.makePageHtml "NotFound" Nothing - - - --- SERVE FILES - - -serveFiles :: Snap () -serveFiles = - do path <- getSafePath - guard =<< liftIO (Dir.doesFileExist path) - serveElm path <|> serveFilePretty path - - - --- SERVE FILES + CODE HIGHLIGHTING - - -serveFilePretty :: FilePath -> Snap () -serveFilePretty path = - let - possibleExtensions = - getSubExts (takeExtensions path) - in - case mconcat (map lookupMimeType possibleExtensions) of - Nothing -> - serveCode path - - Just mimeType -> - serveFileAs mimeType path - - -getSubExts :: String -> [String] -getSubExts fullExtension = - if null fullExtension then - [] - else - fullExtension : getSubExts (takeExtensions (drop 1 fullExtension)) - - -serveCode :: String -> Snap () -serveCode path = - do code <- liftIO (BS.readFile path) - modifyResponse (setContentType "text/html") - writeBuilder $ - Help.makeCodeHtml ('~' : '/' : path) (B.byteString code) - - - --- SERVE ELM - - -serveElm :: FilePath -> Snap () -serveElm path = - do guard (takeExtension path == ".elm") - modifyResponse (setContentType "text/html") - result <- liftIO $ compile path - case result of - Right builder -> - writeBuilder builder - - Left exit -> - writeBuilder $ Help.makePageHtml "Errors" $ Just $ - Exit.toJson $ Exit.reactorToReport exit - - -compile :: FilePath -> IO (Either Exit.Reactor B.Builder) -compile path = - do maybeRoot <- Stuff.findRoot - case maybeRoot of - Nothing -> - return $ Left $ Exit.ReactorNoOutline - - Just root -> - BW.withScope $ \scope -> Stuff.withRootLock root $ Task.run $ - do details <- Task.eio Exit.ReactorBadDetails $ Details.load Reporting.silent scope root - artifacts <- Task.eio Exit.ReactorBadBuild $ Build.fromPaths Reporting.silent root details (NE.List path []) - javascript <- Task.mapError Exit.ReactorBadGenerate $ Generate.dev root details artifacts - let (NE.List name _) = Build.getRootNames artifacts - return $ Html.sandwich name javascript - - - --- SERVE STATIC ASSETS - - -serveAssets :: Snap () -serveAssets = - do path <- getSafePath - case StaticFiles.lookup path of - Nothing -> - pass - - Just (content, mimeType) -> - do modifyResponse (setContentType (mimeType <> ";charset=utf-8")) - writeBS content - - - --- MIME TYPES - - -lookupMimeType :: FilePath -> Maybe BS.ByteString -lookupMimeType ext = - HashMap.lookup ext mimeTypeDict - - -(==>) :: a -> b -> (a,b) -(==>) a b = - (a, b) - - -mimeTypeDict :: HashMap.HashMap FilePath BS.ByteString -mimeTypeDict = - HashMap.fromList - [ ".asc" ==> "text/plain" - , ".asf" ==> "video/x-ms-asf" - , ".asx" ==> "video/x-ms-asf" - , ".avi" ==> "video/x-msvideo" - , ".bz2" ==> "application/x-bzip" - , ".css" ==> "text/css" - , ".dtd" ==> "text/xml" - , ".dvi" ==> "application/x-dvi" - , ".gif" ==> "image/gif" - , ".gz" ==> "application/x-gzip" - , ".htm" ==> "text/html" - , ".html" ==> "text/html" - , ".ico" ==> "image/x-icon" - , ".jpeg" ==> "image/jpeg" - , ".jpg" ==> "image/jpeg" - , ".js" ==> "text/javascript" - , ".json" ==> "application/json" - , ".m3u" ==> "audio/x-mpegurl" - , ".mov" ==> "video/quicktime" - , ".mp3" ==> "audio/mpeg" - , ".mp4" ==> "video/mp4" - , ".mpeg" ==> "video/mpeg" - , ".mpg" ==> "video/mpeg" - , ".ogg" ==> "application/ogg" - , ".otf" ==> "font/otf" - , ".pac" ==> "application/x-ns-proxy-autoconfig" - , ".pdf" ==> "application/pdf" - , ".png" ==> "image/png" - , ".qt" ==> "video/quicktime" - , ".sfnt" ==> "font/sfnt" - , ".sig" ==> "application/pgp-signature" - , ".spl" ==> "application/futuresplash" - , ".svg" ==> "image/svg+xml" - , ".swf" ==> "application/x-shockwave-flash" - , ".tar" ==> "application/x-tar" - , ".tar.bz2" ==> "application/x-bzip-compressed-tar" - , ".tar.gz" ==> "application/x-tgz" - , ".tbz" ==> "application/x-bzip-compressed-tar" - , ".text" ==> "text/plain" - , ".tgz" ==> "application/x-tgz" - , ".ttf" ==> "font/ttf" - , ".txt" ==> "text/plain" - , ".wav" ==> "audio/x-wav" - , ".wax" ==> "audio/x-ms-wax" - , ".webm" ==> "video/webm" - , ".webp" ==> "image/webp" - , ".wma" ==> "audio/x-ms-wma" - , ".wmv" ==> "video/x-ms-wmv" - , ".woff" ==> "font/woff" - , ".woff2" ==> "font/woff2" - , ".xbm" ==> "image/x-xbitmap" - , ".xml" ==> "text/xml" - , ".xpm" ==> "image/x-xpixmap" - , ".xwd" ==> "image/x-xwindowdump" - , ".zip" ==> "application/zip" - ] diff --git a/terminal/src/Develop/Generate/Help.hs b/terminal/src/Develop/Generate/Help.hs deleted file mode 100644 index f6fb996a6e..0000000000 --- a/terminal/src/Develop/Generate/Help.hs +++ /dev/null @@ -1,65 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -module Develop.Generate.Help - ( makePageHtml - , makeCodeHtml - ) - where - - -import qualified Data.ByteString.Builder as B -import Data.Monoid ((<>)) -import qualified Data.Name as Name -import Text.RawString.QQ (r) - -import qualified Json.Encode as Encode - - - --- PAGES - - -makePageHtml :: Name.Name -> Maybe Encode.Value -> B.Builder -makePageHtml moduleName maybeFlags = - [r| - - - - - - - - - - -|] - - - --- CODE - - -makeCodeHtml :: FilePath -> B.Builder -> B.Builder -makeCodeHtml title code = - [r| - - - - |] <> B.stringUtf8 title <> [r| - - - - - - -
|] <> code <> [r|
- - -|] diff --git a/terminal/src/Develop/Generate/Index.hs b/terminal/src/Develop/Generate/Index.hs deleted file mode 100644 index 544a61f457..0000000000 --- a/terminal/src/Develop/Generate/Index.hs +++ /dev/null @@ -1,213 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE OverloadedStrings #-} -module Develop.Generate.Index - ( generate - ) - where - - -import Control.Monad (filterM) -import qualified Data.ByteString.Builder as B -import qualified Data.List as List -import qualified Data.Map as Map -import qualified System.Directory as Dir -import System.FilePath ((), splitDirectories, takeExtension) - -import qualified BackgroundWriter as BW -import qualified Develop.Generate.Help as Help -import qualified Elm.Details as Details -import qualified Elm.Outline as Outline -import qualified Elm.Package as Pkg -import qualified Elm.Version as V -import qualified Json.Encode as E -import Json.Encode ((==>)) -import qualified Reporting -import qualified Stuff - - - --- GENERATE - - -generate :: FilePath -> IO B.Builder -generate pwd = - do flags <- getFlags pwd - return $ Help.makePageHtml "Index" (Just (encode flags)) - - - --- FLAGS - - -data Flags = - Flags - { _root :: FilePath - , _pwd :: [String] - , _dirs :: [FilePath] - , _files :: [File] - , _readme :: Maybe String - , _outline :: Maybe Outline.Outline - , _exactDeps :: Map.Map Pkg.Name V.Version - } - - -data File = - File - { _path :: FilePath - , _runnable :: Bool - } - - - --- GET FLAGS - - -getFlags :: FilePath -> IO Flags -getFlags pwd = - do contents <- Dir.getDirectoryContents pwd - root <- Dir.getCurrentDirectory - dirs <- getDirs pwd contents - files <- getFiles pwd contents - readme <- getReadme pwd - outline <- getOutline - exactDeps <- getExactDeps outline - return $ - Flags - { _root = root - , _pwd = dropWhile ("." ==) (splitDirectories pwd) - , _dirs = dirs - , _files = files - , _readme = readme - , _outline = outline - , _exactDeps = exactDeps - } - - - --- README - - -getReadme :: FilePath -> IO (Maybe String) -getReadme dir = - do let readmePath = dir "README.md" - exists <- Dir.doesFileExist readmePath - if exists - then Just <$> readFile readmePath - else return Nothing - - - --- GET DIRECTORIES - - -getDirs :: FilePath -> [FilePath] -> IO [FilePath] -getDirs pwd contents = - filterM (Dir.doesDirectoryExist . (pwd )) contents - - - --- GET FILES - - -getFiles :: FilePath -> [FilePath] -> IO [File] -getFiles pwd contents = - do paths <- filterM (Dir.doesFileExist . (pwd )) contents - mapM (toFile pwd) paths - - -toFile :: FilePath -> FilePath -> IO File -toFile pwd path = - if takeExtension path == ".elm" then - do source <- readFile (pwd path) - let hasMain = List.isInfixOf "\nmain " source - return (File path hasMain) - else - return (File path False) - - - --- GET OUTLINE - - -getOutline :: IO (Maybe Outline.Outline) -getOutline = - do maybeRoot <- Stuff.findRoot - case maybeRoot of - Nothing -> - return Nothing - - Just root -> - do result <- Outline.read root - case result of - Left _ -> return Nothing - Right outline -> return (Just outline) - - - --- GET EXACT DEPS - - --- TODO revamp how `elm reactor` works so that this can go away. --- I am trying to "just get it working again" at this point though. --- -getExactDeps :: Maybe Outline.Outline -> IO (Map.Map Pkg.Name V.Version) -getExactDeps maybeOutline = - case maybeOutline of - Nothing -> - return Map.empty - - Just outline -> - case outline of - Outline.App _ -> - return Map.empty - - Outline.Pkg _ -> - do maybeRoot <- Stuff.findRoot - case maybeRoot of - Nothing -> - return Map.empty - - Just root -> - BW.withScope $ \scope -> - do result <- Details.load Reporting.silent scope root - case result of - Left _ -> - return Map.empty - - Right (Details.Details _ validOutline _ _ _ _) -> - case validOutline of - Details.ValidApp _ -> - return Map.empty - - Details.ValidPkg _ _ solution -> - return solution - - - --- ENCODE - - -encode :: Flags -> E.Value -encode (Flags root pwd dirs files readme outline exactDeps) = - E.object - [ "root" ==> encodeFilePath root - , "pwd" ==> E.list encodeFilePath pwd - , "dirs" ==> E.list encodeFilePath dirs - , "files" ==> E.list encodeFile files - , "readme" ==> maybe E.null E.chars readme - , "outline" ==> maybe E.null Outline.encode outline - , "exactDeps" ==> E.dict Pkg.toJsonString V.encode exactDeps - ] - - -encodeFilePath :: FilePath -> E.Value -encodeFilePath filePath = - E.chars filePath - - -encodeFile :: File -> E.Value -encodeFile (File path hasMain) = - E.object - [ "name" ==> encodeFilePath path - , "runnable" ==> E.bool hasMain - ] diff --git a/terminal/src/Develop/Socket.hs b/terminal/src/Develop/Socket.hs deleted file mode 100644 index 067badf66a..0000000000 --- a/terminal/src/Develop/Socket.hs +++ /dev/null @@ -1,43 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE OverloadedStrings #-} -module Develop.Socket (watchFile) where - -import Control.Concurrent (forkIO, threadDelay) -import Control.Exception (SomeException, catch) -import qualified Data.ByteString.Char8 as BS -import qualified Network.WebSockets as WS -import qualified System.FSNotify.Devel as Notify -import qualified System.FSNotify as Notify - - - -watchFile :: FilePath -> WS.PendingConnection -> IO () -watchFile watchedFile pendingConnection = - do connection <- WS.acceptRequest pendingConnection - - Notify.withManager $ \mgmt -> - do stop <- Notify.treeExtAny mgmt "." ".elm" print - tend connection - stop - - -tend :: WS.Connection -> IO () -tend connection = - let - pinger :: Integer -> IO a - pinger n = - do threadDelay (5 * 1000 * 1000) - WS.sendPing connection (BS.pack (show n)) - pinger (n + 1) - - receiver :: IO () - receiver = - do _ <- WS.receiveDataMessage connection - receiver - - shutdown :: SomeException -> IO () - shutdown _ = - return () - in - do _pid <- forkIO (receiver `catch` shutdown) - pinger 1 `catch` shutdown diff --git a/terminal/src/Develop/StaticFiles.hs b/terminal/src/Develop/StaticFiles.hs deleted file mode 100644 index 94ee72dc66..0000000000 --- a/terminal/src/Develop/StaticFiles.hs +++ /dev/null @@ -1,123 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} -module Develop.StaticFiles - ( lookup - , cssPath - , elmPath - , waitingPath - ) - where - -import Prelude hiding (lookup) -import qualified Data.ByteString as BS -import Data.FileEmbed (bsToExp) -import qualified Data.HashMap.Strict as HM -import Language.Haskell.TH (runIO) -import System.FilePath (()) - -import qualified Develop.StaticFiles.Build as Build - - - --- FILE LOOKUP - - -type MimeType = - BS.ByteString - - -lookup :: FilePath -> Maybe (BS.ByteString, MimeType) -lookup path = - HM.lookup path dict - - -dict :: HM.HashMap FilePath (BS.ByteString, MimeType) -dict = - HM.fromList - [ faviconPath ==> (favicon , "image/x-icon") - , elmPath ==> (elm , "application/javascript") - , cssPath ==> (css , "text/css") - , codeFontPath ==> (codeFont, "font/ttf") - , sansFontPath ==> (sansFont, "font/ttf") - ] - - -(==>) :: a -> b -> (a,b) -(==>) a b = - (a, b) - - - --- PATHS - - -faviconPath :: FilePath -faviconPath = - "favicon.ico" - - -waitingPath :: FilePath -waitingPath = - "_elm" "waiting.gif" - - -elmPath :: FilePath -elmPath = - "_elm" "elm.js" - - -cssPath :: FilePath -cssPath = - "_elm" "styles.css" - - -codeFontPath :: FilePath -codeFontPath = - "_elm" "source-code-pro.ttf" - - -sansFontPath :: FilePath -sansFontPath = - "_elm" "source-sans-pro.ttf" - - - --- ELM - - -elm :: BS.ByteString -elm = - $(bsToExp =<< runIO Build.buildReactorFrontEnd) - - - --- CSS - - -css :: BS.ByteString -css = - $(bsToExp =<< runIO (Build.readAsset "styles.css")) - - - --- FONTS - - -codeFont :: BS.ByteString -codeFont = - $(bsToExp =<< runIO (Build.readAsset "source-code-pro.ttf")) - - -sansFont :: BS.ByteString -sansFont = - $(bsToExp =<< runIO (Build.readAsset "source-sans-pro.ttf")) - - - --- IMAGES - - -favicon :: BS.ByteString -favicon = - $(bsToExp =<< runIO (Build.readAsset "favicon.ico")) diff --git a/terminal/src/Develop/StaticFiles/Build.hs b/terminal/src/Develop/StaticFiles/Build.hs deleted file mode 100644 index c61fae579e..0000000000 --- a/terminal/src/Develop/StaticFiles/Build.hs +++ /dev/null @@ -1,73 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module Develop.StaticFiles.Build - ( readAsset - , buildReactorFrontEnd - ) - where - - -import qualified Data.ByteString as BS -import qualified Data.ByteString.Builder as B -import qualified Data.ByteString.Lazy as LBS -import qualified Data.NonEmptyList as NE -import qualified System.Directory as Dir -import System.FilePath (()) - -import qualified BackgroundWriter as BW -import qualified Build -import qualified Elm.Details as Details -import qualified Generate -import qualified Reporting -import qualified Reporting.Exit as Exit -import qualified Reporting.Task as Task - - - --- ASSETS - - -readAsset :: FilePath -> IO BS.ByteString -readAsset path = - BS.readFile ("reactor" "assets" path) - - - --- BUILD REACTOR ELM - - -buildReactorFrontEnd :: IO BS.ByteString -buildReactorFrontEnd = - BW.withScope $ \scope -> - Dir.withCurrentDirectory "reactor" $ - do root <- Dir.getCurrentDirectory - runTaskUnsafe $ - do details <- Task.eio Exit.ReactorBadDetails $ Details.load Reporting.silent scope root - artifacts <- Task.eio Exit.ReactorBadBuild $ Build.fromPaths Reporting.silent root details paths - javascript <- Task.mapError Exit.ReactorBadGenerate $ Generate.prod root details artifacts - return (LBS.toStrict (B.toLazyByteString javascript)) - - -paths :: NE.List FilePath -paths = - NE.List - ("src" "NotFound.elm") - [ "src" "Errors.elm" - , "src" "Index.elm" - ] - - -runTaskUnsafe :: Task.Task Exit.Reactor a -> IO a -runTaskUnsafe task = - do result <- Task.run task - case result of - Right a -> - return a - - Left exit -> - do Exit.toStderr (Exit.reactorToReport exit) - error - "\n--------------------------------------------------------\ - \\nError in Develop.StaticFiles.Build.buildReactorFrontEnd\ - \\nCompile with `elm make` directly to figure it out faster\ - \\n--------------------------------------------------------\ - \\n" diff --git a/terminal/src/Diff.hs b/terminal/src/Diff.hs deleted file mode 100644 index 492315365c..0000000000 --- a/terminal/src/Diff.hs +++ /dev/null @@ -1,359 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE OverloadedStrings #-} -module Diff - ( Args(..) - , run - ) - where - - -import qualified Data.List as List -import qualified Data.Map as Map -import qualified Data.Maybe as Maybe -import qualified Data.Name as Name -import qualified Data.NonEmptyList as NE - -import qualified BackgroundWriter as BW -import qualified Build -import Deps.Diff (PackageChanges(..), ModuleChanges(..), Changes(..)) -import qualified Deps.Diff as DD -import qualified Deps.Registry as Registry -import qualified Elm.Compiler.Type as Type -import qualified Elm.Details as Details -import qualified Elm.Docs as Docs -import qualified Elm.Magnitude as M -import qualified Elm.Outline as Outline -import qualified Elm.Package as Pkg -import qualified Elm.Version as V -import qualified Http -import qualified Reporting -import Reporting.Doc ((<>), (<+>)) -import qualified Reporting.Doc as D -import qualified Reporting.Exit as Exit -import qualified Reporting.Exit.Help as Help -import qualified Reporting.Render.Type.Localizer as L -import qualified Reporting.Task as Task -import qualified Stuff - - - --- RUN - - -data Args - = CodeVsLatest - | CodeVsExactly V.Version - | LocalInquiry V.Version V.Version - | GlobalInquiry Pkg.Name V.Version V.Version - - -run :: Args -> () -> IO () -run args () = - Reporting.attempt Exit.diffToReport $ - Task.run $ - do env <- getEnv - diff env args - - - --- ENVIRONMENT - - -data Env = - Env - { _maybeRoot :: Maybe FilePath - , _cache :: Stuff.PackageCache - , _manager :: Http.Manager - , _registry :: Registry.Registry - } - - -getEnv :: Task Env -getEnv = - do maybeRoot <- Task.io $ Stuff.findRoot - cache <- Task.io $ Stuff.getPackageCache - manager <- Task.io $ Http.getManager - registry <- Task.eio Exit.DiffMustHaveLatestRegistry $ Registry.latest manager cache - return (Env maybeRoot cache manager registry) - - - --- DIFF - - -type Task a = - Task.Task Exit.Diff a - - -diff :: Env -> Args -> Task () -diff env@(Env _ _ _ registry) args = - case args of - GlobalInquiry name v1 v2 -> - case Registry.getVersions' name registry of - Right vsns -> - do oldDocs <- getDocs env name vsns (min v1 v2) - newDocs <- getDocs env name vsns (max v1 v2) - writeDiff oldDocs newDocs - - Left suggestions -> - Task.throw $ Exit.DiffUnknownPackage name suggestions - - LocalInquiry v1 v2 -> - do (name, vsns) <- readOutline env - oldDocs <- getDocs env name vsns (min v1 v2) - newDocs <- getDocs env name vsns (max v1 v2) - writeDiff oldDocs newDocs - - CodeVsLatest -> - do (name, vsns) <- readOutline env - oldDocs <- getLatestDocs env name vsns - newDocs <- generateDocs env - writeDiff oldDocs newDocs - - CodeVsExactly version -> - do (name, vsns) <- readOutline env - oldDocs <- getDocs env name vsns version - newDocs <- generateDocs env - writeDiff oldDocs newDocs - - - --- GET DOCS - - -getDocs :: Env -> Pkg.Name -> Registry.KnownVersions -> V.Version -> Task Docs.Documentation -getDocs (Env _ cache manager _) name (Registry.KnownVersions latest previous) version = - if latest == version || elem version previous - then Task.eio (Exit.DiffDocsProblem version) $ DD.getDocs cache manager name version - else Task.throw $ Exit.DiffUnknownVersion name version (latest:previous) - - -getLatestDocs :: Env -> Pkg.Name -> Registry.KnownVersions -> Task Docs.Documentation -getLatestDocs (Env _ cache manager _) name (Registry.KnownVersions latest _) = - Task.eio (Exit.DiffDocsProblem latest) $ DD.getDocs cache manager name latest - - - --- READ OUTLINE - - -readOutline :: Env -> Task (Pkg.Name, Registry.KnownVersions) -readOutline (Env maybeRoot _ _ registry) = - case maybeRoot of - Nothing -> - Task.throw $ Exit.DiffNoOutline - - Just root -> - do result <- Task.io $ Outline.read root - case result of - Left err -> - Task.throw $ Exit.DiffBadOutline err - - Right outline -> - case outline of - Outline.App _ -> - Task.throw $ Exit.DiffApplication - - Outline.Pkg (Outline.PkgOutline pkg _ _ _ _ _ _ _) -> - case Registry.getVersions pkg registry of - Just vsns -> return (pkg, vsns) - Nothing -> Task.throw Exit.DiffUnpublished - - - --- GENERATE DOCS - - -generateDocs :: Env -> Task Docs.Documentation -generateDocs (Env maybeRoot _ _ _) = - case maybeRoot of - Nothing -> - Task.throw $ Exit.DiffNoOutline - - Just root -> - do details <- - Task.eio Exit.DiffBadDetails $ BW.withScope $ \scope -> - Details.load Reporting.silent scope root - - case Details._outline details of - Details.ValidApp _ -> - Task.throw $ Exit.DiffApplication - - Details.ValidPkg _ exposed _ -> - case exposed of - [] -> - Task.throw $ Exit.DiffNoExposed - - e:es -> - Task.eio Exit.DiffBadBuild $ - Build.fromExposed Reporting.silent root details Build.KeepDocs (NE.List e es) - - - --- WRITE DIFF - - -writeDiff :: Docs.Documentation -> Docs.Documentation -> Task () -writeDiff oldDocs newDocs = - let - changes = DD.diff oldDocs newDocs - localizer = L.fromNames (Map.union oldDocs newDocs) - in - Task.io $ Help.toStdout $ toDoc localizer changes <> "\n" - - - --- TO DOC - - -toDoc :: L.Localizer -> PackageChanges -> D.Doc -toDoc localizer changes@(PackageChanges added changed removed) = - if null added && Map.null changed && null removed then - "No API changes detected, so this is a" <+> D.green "PATCH" <+> "change." - else - let - magDoc = - D.fromChars (M.toChars (DD.toMagnitude changes)) - - header = - "This is a" <+> D.green magDoc <+> "change." - - addedChunk = - if null added then [] else - [ Chunk "ADDED MODULES" M.MINOR $ - D.vcat $ map D.fromName added - ] - - removedChunk = - if null removed then [] else - [ Chunk "REMOVED MODULES" M.MAJOR $ - D.vcat $ map D.fromName removed - ] - - chunks = - addedChunk ++ removedChunk ++ map (changesToChunk localizer) (Map.toList changed) - in - D.vcat (header : "" : map chunkToDoc chunks) - - -data Chunk = - Chunk - { _title :: String - , _magnitude :: M.Magnitude - , _details :: D.Doc - } - - -chunkToDoc :: Chunk -> D.Doc -chunkToDoc (Chunk title magnitude details) = - let - header = - "----" <+> D.fromChars title <+> "-" <+> D.fromChars (M.toChars magnitude) <+> "----" - in - D.vcat - [ D.dullcyan header - , "" - , D.indent 4 details - , "" - , "" - ] - - -changesToChunk :: L.Localizer -> (Name.Name, ModuleChanges) -> Chunk -changesToChunk localizer (name, changes@(ModuleChanges unions aliases values binops)) = - let - magnitude = - DD.moduleChangeMagnitude changes - - (unionAdd, unionChange, unionRemove) = - changesToDocTriple (unionToDoc localizer) unions - - (aliasAdd, aliasChange, aliasRemove) = - changesToDocTriple (aliasToDoc localizer) aliases - - (valueAdd, valueChange, valueRemove) = - changesToDocTriple (valueToDoc localizer) values - - (binopAdd, binopChange, binopRemove) = - changesToDocTriple (binopToDoc localizer) binops - in - Chunk (Name.toChars name) magnitude $ - D.vcat $ List.intersperse "" $ Maybe.catMaybes $ - [ changesToDoc "Added" unionAdd aliasAdd valueAdd binopAdd - , changesToDoc "Removed" unionRemove aliasRemove valueRemove binopRemove - , changesToDoc "Changed" unionChange aliasChange valueChange binopChange - ] - - -changesToDocTriple :: (k -> v -> D.Doc) -> Changes k v -> ([D.Doc], [D.Doc], [D.Doc]) -changesToDocTriple entryToDoc (Changes added changed removed) = - let - indented (name, value) = - D.indent 4 (entryToDoc name value) - - diffed (name, (oldValue, newValue)) = - D.vcat - [ " - " <> entryToDoc name oldValue - , " + " <> entryToDoc name newValue - , "" - ] - in - ( map indented (Map.toList added) - , map diffed (Map.toList changed) - , map indented (Map.toList removed) - ) - - -changesToDoc :: String -> [D.Doc] -> [D.Doc] -> [D.Doc] -> [D.Doc] -> Maybe D.Doc -changesToDoc categoryName unions aliases values binops = - if null unions && null aliases && null values && null binops then - Nothing - - else - Just $ D.vcat $ - D.fromChars categoryName <> ":" : unions ++ aliases ++ binops ++ values - - -unionToDoc :: L.Localizer -> Name.Name -> Docs.Union -> D.Doc -unionToDoc localizer name (Docs.Union _ tvars ctors) = - let - setup = - "type" <+> D.fromName name <+> D.hsep (map D.fromName tvars) - - ctorDoc (ctor, tipes) = - typeDoc localizer (Type.Type ctor tipes) - in - D.hang 4 (D.sep (setup : zipWith (<+>) ("=" : repeat "|") (map ctorDoc ctors))) - - -aliasToDoc :: L.Localizer -> Name.Name -> Docs.Alias -> D.Doc -aliasToDoc localizer name (Docs.Alias _ tvars tipe) = - let - declaration = - "type" <+> "alias" <+> D.hsep (map D.fromName (name:tvars)) <+> "=" - in - D.hang 4 (D.sep [ declaration, typeDoc localizer tipe ]) - - -valueToDoc :: L.Localizer -> Name.Name -> Docs.Value -> D.Doc -valueToDoc localizer name (Docs.Value _ tipe) = - D.hang 4 $ D.sep [ D.fromName name <+> ":", typeDoc localizer tipe ] - - -binopToDoc :: L.Localizer -> Name.Name -> Docs.Binop -> D.Doc -binopToDoc localizer name (Docs.Binop _ tipe associativity (Docs.Precedence n)) = - "(" <> D.fromName name <> ")" <+> ":" <+> typeDoc localizer tipe <> D.black details - where - details = - " (" <> D.fromName assoc <> "/" <> D.fromInt n <> ")" - - assoc = - case associativity of - Docs.Left -> "left" - Docs.Non -> "non" - Docs.Right -> "right" - - -typeDoc :: L.Localizer -> Type.Type -> D.Doc -typeDoc localizer tipe = - Type.toDoc localizer Type.None tipe diff --git a/terminal/src/Init.hs b/terminal/src/Init.hs deleted file mode 100644 index 21b5a78b6c..0000000000 --- a/terminal/src/Init.hs +++ /dev/null @@ -1,104 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module Init - ( run - ) - where - - -import Prelude hiding (init) -import qualified Data.Map as Map -import qualified Data.NonEmptyList as NE -import qualified System.Directory as Dir - -import qualified Deps.Solver as Solver -import qualified Elm.Constraint as Con -import qualified Elm.Outline as Outline -import qualified Elm.Package as Pkg -import qualified Elm.Version as V -import qualified Reporting -import qualified Reporting.Doc as D -import qualified Reporting.Exit as Exit - - - --- RUN - - -run :: () -> () -> IO () -run () () = - Reporting.attempt Exit.initToReport $ - do exists <- Dir.doesFileExist "elm.json" - if exists - then return (Left Exit.InitAlreadyExists) - else - do approved <- Reporting.ask question - if approved - then init - else - do putStrLn "Okay, I did not make any changes!" - return (Right ()) - - -question :: D.Doc -question = - D.stack - [ D.fillSep - ["Hello!" - ,"Elm","projects","always","start","with","an",D.green "elm.json","file." - ,"I","can","create","them!" - ] - , D.reflow - "Now you may be wondering, what will be in this file? How do I add Elm files to\ - \ my project? How do I see it in the browser? How will my code grow? Do I need\ - \ more directories? What about tests? Etc." - , D.fillSep - ["Check","out",D.cyan (D.fromChars (D.makeLink "init")) - ,"for","all","the","answers!" - ] - , "Knowing all that, would you like me to create an elm.json file now? [Y/n]: " - ] - - - --- INIT - - -init :: IO (Either Exit.Init ()) -init = - do eitherEnv <- Solver.initEnv - case eitherEnv of - Left problem -> - return (Left (Exit.InitRegistryProblem problem)) - - Right (Solver.Env cache _ connection registry) -> - do result <- Solver.verify cache connection registry defaults - case result of - Solver.Err exit -> - return (Left (Exit.InitSolverProblem exit)) - - Solver.NoSolution -> - return (Left (Exit.InitNoSolution (Map.keys defaults))) - - Solver.NoOfflineSolution -> - return (Left (Exit.InitNoOfflineSolution (Map.keys defaults))) - - Solver.Ok details -> - let - solution = Map.map (\(Solver.Details vsn _) -> vsn) details - directs = Map.intersection solution defaults - indirects = Map.difference solution defaults - in - do Dir.createDirectoryIfMissing True "src" - Outline.write "." $ Outline.App $ - Outline.AppOutline V.compiler (NE.List (Outline.RelativeSrcDir "src") []) directs indirects Map.empty Map.empty - putStrLn "Okay, I created it. Now read that link!" - return (Right ()) - - -defaults :: Map.Map Pkg.Name Con.Constraint -defaults = - Map.fromList - [ (Pkg.core, Con.anything) - , (Pkg.browser, Con.anything) - , (Pkg.html, Con.anything) - ] diff --git a/terminal/src/Install.hs b/terminal/src/Install.hs deleted file mode 100644 index 48e52a4327..0000000000 --- a/terminal/src/Install.hs +++ /dev/null @@ -1,425 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module Install - ( Args(..) - , run - ) - where - - -import Data.Map ((!)) -import qualified Data.Map as Map -import qualified Data.Map.Merge.Strict as Map - -import qualified BackgroundWriter as BW -import qualified Deps.Solver as Solver -import qualified Deps.Registry as Registry -import qualified Elm.Constraint as C -import qualified Elm.Details as Details -import qualified Elm.Package as Pkg -import qualified Elm.Outline as Outline -import qualified Elm.Version as V -import qualified Reporting -import Reporting.Doc ((<>), (<+>)) -import qualified Reporting.Doc as D -import qualified Reporting.Exit as Exit -import qualified Reporting.Task as Task -import qualified Stuff - - - --- RUN - - -data Args - = NoArgs - | Install Pkg.Name - - -run :: Args -> () -> IO () -run args () = - Reporting.attempt Exit.installToReport $ - do maybeRoot <- Stuff.findRoot - case maybeRoot of - Nothing -> - return (Left Exit.InstallNoOutline) - - Just root -> - case args of - NoArgs -> - do elmHome <- Stuff.getElmHome - return (Left (Exit.InstallNoArgs elmHome)) - - Install pkg -> - Task.run $ - do env <- Task.eio Exit.InstallBadRegistry $ Solver.initEnv - oldOutline <- Task.eio Exit.InstallBadOutline $ Outline.read root - case oldOutline of - Outline.App outline -> - do changes <- makeAppPlan env pkg outline - attemptChanges root env oldOutline V.toChars changes - - Outline.Pkg outline -> - do changes <- makePkgPlan env pkg outline - attemptChanges root env oldOutline C.toChars changes - - - --- ATTEMPT CHANGES - - -data Changes vsn - = AlreadyInstalled - | PromoteTest Outline.Outline - | PromoteIndirect Outline.Outline - | Changes (Map.Map Pkg.Name (Change vsn)) Outline.Outline - - -type Task = Task.Task Exit.Install - - -attemptChanges :: FilePath -> Solver.Env -> Outline.Outline -> (a -> String) -> Changes a -> Task () -attemptChanges root env oldOutline toChars changes = - case changes of - AlreadyInstalled -> - Task.io $ putStrLn "It is already installed!" - - PromoteIndirect newOutline -> - attemptChangesHelp root env oldOutline newOutline $ - D.vcat - [ D.fillSep - ["I","found","it","in","your","elm.json","file," - ,"but","in","the",D.dullyellow "\"indirect\"","dependencies." - ] - , D.fillSep - ["Should","I","move","it","into",D.green "\"direct\"" - ,"dependencies","for","more","general","use?","[Y/n]: " - ] - ] - - PromoteTest newOutline -> - attemptChangesHelp root env oldOutline newOutline $ - D.vcat - [ D.fillSep - ["I","found","it","in","your","elm.json","file," - ,"but","in","the",D.dullyellow "\"test-dependencies\"","field." - ] - , D.fillSep - ["Should","I","move","it","into",D.green "\"dependencies\"" - ,"for","more","general","use?","[Y/n]: " - ] - ] - - Changes changeDict newOutline -> - let - widths = Map.foldrWithKey (widen toChars) (Widths 0 0 0) changeDict - changeDocs = Map.foldrWithKey (addChange toChars widths) (Docs [] [] []) changeDict - in - attemptChangesHelp root env oldOutline newOutline $ D.vcat $ - [ "Here is my plan:" - , viewChangeDocs changeDocs - , "" - , "Would you like me to update your elm.json accordingly? [Y/n]: " - ] - - -attemptChangesHelp :: FilePath -> Solver.Env -> Outline.Outline -> Outline.Outline -> D.Doc -> Task () -attemptChangesHelp root env oldOutline newOutline question = - Task.eio Exit.InstallBadDetails $ - BW.withScope $ \scope -> - do approved <- Reporting.ask question - if approved - then - do Outline.write root newOutline - result <- Details.verifyInstall scope root env newOutline - case result of - Left exit -> - do Outline.write root oldOutline - return (Left exit) - - Right () -> - do putStrLn "Success!" - return (Right ()) - else - do putStrLn "Okay, I did not change anything!" - return (Right ()) - - - --- MAKE APP PLAN - - -makeAppPlan :: Solver.Env -> Pkg.Name -> Outline.AppOutline -> Task (Changes V.Version) -makeAppPlan (Solver.Env cache _ connection registry) pkg outline@(Outline.AppOutline _ _ direct indirect testDirect testIndirect) = - if Map.member pkg direct then - return AlreadyInstalled - - else - -- is it already indirect? - case Map.lookup pkg indirect of - Just vsn -> - return $ PromoteIndirect $ Outline.App $ - outline - { Outline._app_deps_direct = Map.insert pkg vsn direct - , Outline._app_deps_indirect = Map.delete pkg indirect - } - - Nothing -> - -- is it already a test dependency? - case Map.lookup pkg testDirect of - Just vsn -> - return $ PromoteTest $ Outline.App $ - outline - { Outline._app_deps_direct = Map.insert pkg vsn direct - , Outline._app_test_direct = Map.delete pkg testDirect - } - - Nothing -> - -- is it already an indirect test dependency? - case Map.lookup pkg testIndirect of - Just vsn -> - return $ PromoteTest $ Outline.App $ - outline - { Outline._app_deps_direct = Map.insert pkg vsn direct - , Outline._app_test_indirect = Map.delete pkg testIndirect - } - - Nothing -> - -- finally try to add it from scratch - case Registry.getVersions' pkg registry of - Left suggestions -> - case connection of - Solver.Online _ -> Task.throw (Exit.InstallUnknownPackageOnline pkg suggestions) - Solver.Offline -> Task.throw (Exit.InstallUnknownPackageOffline pkg suggestions) - - Right _ -> - do result <- Task.io $ Solver.addToApp cache connection registry pkg outline - case result of - Solver.Ok (Solver.AppSolution old new app) -> - return (Changes (detectChanges old new) (Outline.App app)) - - Solver.NoSolution -> - Task.throw (Exit.InstallNoOnlineAppSolution pkg) - - Solver.NoOfflineSolution -> - Task.throw (Exit.InstallNoOfflineAppSolution pkg) - - Solver.Err exit -> - Task.throw (Exit.InstallHadSolverTrouble exit) - - - --- MAKE PACKAGE PLAN - - -makePkgPlan :: Solver.Env -> Pkg.Name -> Outline.PkgOutline -> Task (Changes C.Constraint) -makePkgPlan (Solver.Env cache _ connection registry) pkg outline@(Outline.PkgOutline _ _ _ _ _ deps test _) = - if Map.member pkg deps then - return AlreadyInstalled - else - -- is already in test dependencies? - case Map.lookup pkg test of - Just con -> - return $ PromoteTest $ Outline.Pkg $ - outline - { Outline._pkg_deps = Map.insert pkg con deps - , Outline._pkg_test_deps = Map.delete pkg test - } - - Nothing -> - -- try to add a new dependency - case Registry.getVersions' pkg registry of - Left suggestions -> - case connection of - Solver.Online _ -> Task.throw (Exit.InstallUnknownPackageOnline pkg suggestions) - Solver.Offline -> Task.throw (Exit.InstallUnknownPackageOffline pkg suggestions) - - Right (Registry.KnownVersions _ _) -> - do let old = Map.union deps test - let cons = Map.insert pkg C.anything old - result <- Task.io $ Solver.verify cache connection registry cons - case result of - Solver.Ok solution -> - let - (Solver.Details vsn _) = solution ! pkg - - con = C.untilNextMajor vsn - new = Map.insert pkg con old - changes = detectChanges old new - news = Map.mapMaybe keepNew changes - in - return $ Changes changes $ Outline.Pkg $ - outline - { Outline._pkg_deps = addNews (Just pkg) news deps - , Outline._pkg_test_deps = addNews Nothing news test - } - - Solver.NoSolution -> - Task.throw (Exit.InstallNoOnlinePkgSolution pkg) - - Solver.NoOfflineSolution -> - Task.throw (Exit.InstallNoOfflinePkgSolution pkg) - - Solver.Err exit -> - Task.throw (Exit.InstallHadSolverTrouble exit) - - -addNews :: Maybe Pkg.Name -> Map.Map Pkg.Name C.Constraint -> Map.Map Pkg.Name C.Constraint -> Map.Map Pkg.Name C.Constraint -addNews pkg new old = - Map.merge - Map.preserveMissing - (Map.mapMaybeMissing (\k c -> if Just k == pkg then Just c else Nothing)) - (Map.zipWithMatched (\_ _ n -> n)) - old - new - - - --- CHANGES - - -data Change a - = Insert a - | Change a a - | Remove a - - -detectChanges :: (Eq a) => Map.Map Pkg.Name a -> Map.Map Pkg.Name a -> Map.Map Pkg.Name (Change a) -detectChanges old new = - Map.merge - (Map.mapMissing (\_ v -> Remove v)) - (Map.mapMissing (\_ v -> Insert v)) - (Map.zipWithMaybeMatched keepChange) - old - new - - -keepChange :: (Eq v) => k -> v -> v -> Maybe (Change v) -keepChange _ old new = - if old == new then - Nothing - else - Just (Change old new) - - -keepNew :: Change a -> Maybe a -keepNew change = - case change of - Insert a -> - Just a - - Change _ a -> - Just a - - Remove _ -> - Nothing - - - --- VIEW CHANGE DOCS - - -data ChangeDocs = - Docs - { _doc_inserts :: [D.Doc] - , _doc_changes :: [D.Doc] - , _doc_removes :: [D.Doc] - } - - -viewChangeDocs :: ChangeDocs -> D.Doc -viewChangeDocs (Docs inserts changes removes) = - D.indent 2 $ D.vcat $ concat $ - [ viewNonZero "Add:" inserts - , viewNonZero "Change:" changes - , viewNonZero "Remove:" removes - ] - - -viewNonZero :: String -> [D.Doc] -> [D.Doc] -viewNonZero title entries = - if null entries then - [] - else - [ "" - , D.fromChars title - , D.indent 2 (D.vcat entries) - ] - - - --- VIEW CHANGE - - -addChange :: (a -> String) -> Widths -> Pkg.Name -> Change a -> ChangeDocs -> ChangeDocs -addChange toChars widths name change (Docs inserts changes removes) = - case change of - Insert new -> - Docs (viewInsert toChars widths name new : inserts) changes removes - - Change old new -> - Docs inserts (viewChange toChars widths name old new : changes) removes - - Remove old -> - Docs inserts changes (viewRemove toChars widths name old : removes) - - -viewInsert :: (a -> String) -> Widths -> Pkg.Name -> a -> D.Doc -viewInsert toChars (Widths nameWidth leftWidth _) name new = - viewName nameWidth name <+> pad leftWidth (toChars new) - - -viewChange :: (a -> String) -> Widths -> Pkg.Name -> a -> a -> D.Doc -viewChange toChars (Widths nameWidth leftWidth rightWidth) name old new = - D.hsep - [ viewName nameWidth name - , pad leftWidth (toChars old) - , "=>" - , pad rightWidth (toChars new) - ] - - -viewRemove :: (a -> String) -> Widths -> Pkg.Name -> a -> D.Doc -viewRemove toChars (Widths nameWidth leftWidth _) name old = - viewName nameWidth name <+> pad leftWidth (toChars old) - - -viewName :: Int -> Pkg.Name -> D.Doc -viewName width name = - D.fill (width + 3) (D.fromPackage name) - - -pad :: Int -> String -> D.Doc -pad width string = - D.fromChars (replicate (width - length string) ' ') <> D.fromChars string - - - --- WIDTHS - - -data Widths = - Widths - { _name :: !Int - , _left :: !Int - , _right :: !Int - } - - -widen :: (a -> String) -> Pkg.Name -> Change a -> Widths -> Widths -widen toChars pkg change (Widths name left right) = - let - toLength a = - length (toChars a) - - newName = - max name (length (Pkg.toChars pkg)) - in - case change of - Insert new -> - Widths newName (max left (toLength new)) right - - Change old new -> - Widths newName (max left (toLength old)) (max right (toLength new)) - - Remove old -> - Widths newName (max left (toLength old)) right diff --git a/terminal/src/Main.hs b/terminal/src/Main.hs deleted file mode 100644 index e2d3f4083e..0000000000 --- a/terminal/src/Main.hs +++ /dev/null @@ -1,338 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module Main - ( main - ) - where - - -import Prelude hiding (init) -import qualified Data.List as List -import qualified Text.PrettyPrint.ANSI.Leijen as P -import Text.PrettyPrint.ANSI.Leijen ((<>)) -import Text.Read (readMaybe) - -import qualified Elm.Version as V -import Terminal -import Terminal.Helpers - -import qualified Bump -import qualified Develop -import qualified Diff -import qualified Init -import qualified Install -import qualified Make -import qualified Publish -import qualified Repl - - - --- MAIN - - -main :: IO () -main = - Terminal.app intro outro - [ repl - , init - , reactor - , make - , install - , bump - , diff - , publish - ] - - -intro :: P.Doc -intro = - P.vcat - [ P.fillSep - ["Hi,","thank","you","for","trying","out" - ,P.green "Elm" - ,P.green (P.text (V.toChars V.compiler)) <> "." - ,"I hope you like it!" - ] - , "" - , P.black "-------------------------------------------------------------------------------" - , P.black "I highly recommend working through to get started." - , P.black "It teaches many important concepts, including how to use `elm` in the terminal." - , P.black "-------------------------------------------------------------------------------" - ] - - -outro :: P.Doc -outro = - P.fillSep $ map P.text $ words $ - "Be sure to ask on the Elm slack if you run into trouble! Folks are friendly and\ - \ happy to help out. They hang out there because it is fun, so be kind to get the\ - \ best results!" - - - --- INIT - - -init :: Terminal.Command -init = - let - summary = - "Start an Elm project. It creates a starter elm.json file and\ - \ provides a link explaining what to do from there." - - details = - "The `init` command helps start Elm projects:" - - example = - reflow - "It will ask permission to create an elm.json file, the one thing common\ - \ to all Elm projects. It also provides a link explaining what to do from there." - in - Terminal.Command "init" (Common summary) details example noArgs noFlags Init.run - - - --- REPL - - -repl :: Terminal.Command -repl = - let - summary = - "Open up an interactive programming session. Type in Elm expressions\ - \ like (2 + 2) or (String.length \"test\") and see if they equal four!" - - details = - "The `repl` command opens up an interactive programming session:" - - example = - reflow - "Start working through to learn how to use this!\ - \ It has a whole chapter that uses the REPL for everything, so that is probably\ - \ the quickest way to get started." - - replFlags = - flags Repl.Flags - |-- flag "interpreter" interpreter "Path to a alternate JS interpreter, like node or nodejs." - |-- onOff "no-colors" "Turn off the colors in the REPL. This can help if you are having trouble reading the values. Some terminals use a custom color scheme that diverges significantly from the standard ANSI colors, so another path may be to pick a more standard color scheme." - in - Terminal.Command "repl" (Common summary) details example noArgs replFlags Repl.run - - -interpreter :: Parser String -interpreter = - Parser - { _singular = "interpreter" - , _plural = "interpreters" - , _parser = Just - , _suggest = \_ -> return [] - , _examples = \_ -> return ["node","nodejs"] - } - - - --- REACTOR - - -reactor :: Terminal.Command -reactor = - let - summary = - "Compile code with a click. It opens a file viewer in your browser, and\ - \ when you click on an Elm file, it compiles and you see the result." - - details = - "The `reactor` command starts a local server on your computer:" - - example = - reflow - "After running that command, you would have a server at \ - \ that helps with development. It shows your files like a file viewer. If you\ - \ click on an Elm file, it will compile it for you! And you can just press\ - \ the refresh button in the browser to recompile things." - - reactorFlags = - flags Develop.Flags - |-- flag "port" port_ "The port of the server (default: 8000)" - in - Terminal.Command "reactor" (Common summary) details example noArgs reactorFlags Develop.run - - -port_ :: Parser Int -port_ = - Parser - { _singular = "port" - , _plural = "ports" - , _parser = readMaybe - , _suggest = \_ -> return [] - , _examples = \_ -> return ["3000","8000"] - } - - - --- MAKE - - -make :: Terminal.Command -make = - let - details = - "The `make` command compiles Elm code into JS or HTML:" - - example = - stack - [ reflow - "For example:" - , P.indent 4 $ P.green "elm make src/Main.elm" - , reflow - "This tries to compile an Elm file named src/Main.elm, generating an index.html\ - \ file if possible." - ] - - makeFlags = - flags Make.Flags - |-- onOff "debug" "Turn on the time-travelling debugger. It allows you to rewind and replay events. The events can be imported/exported into a file, which makes for very precise bug reports!" - |-- onOff "optimize" "Turn on optimizations to make code smaller and faster. For example, the compiler renames record fields to be as short as possible and unboxes values to reduce allocation." - |-- flag "output" Make.output "Specify the name of the resulting JS file. For example --output=assets/elm.js to generate the JS at assets/elm.js or --output=/dev/null to generate no output at all!" - |-- flag "report" Make.reportType "You can say --report=json to get error messages as JSON. This is only really useful if you are an editor plugin. Humans should avoid it!" - |-- flag "docs" Make.docsFile "Generate a JSON file of documentation for a package. Eventually it will be possible to preview docs with `reactor` because it is quite hard to deal with these JSON files directly." - in - Terminal.Command "make" Uncommon details example (zeroOrMore elmFile) makeFlags Make.run - - - --- INSTALL - - -install :: Terminal.Command -install = - let - details = - "The `install` command fetches packages from for\ - \ use in your project:" - - example = - stack - [ reflow - "For example, if you want to get packages for HTTP and JSON, you would say:" - , P.indent 4 $ P.green $ P.vcat $ - [ "elm install elm/http" - , "elm install elm/json" - ] - , reflow - "Notice that you must say the AUTHOR name and PROJECT name! After running those\ - \ commands, you could say `import Http` or `import Json.Decode` in your code." - , reflow - "What if two projects use different versions of the same package? No problem!\ - \ Each project is independent, so there cannot be conflicts like that!" - ] - - installArgs = - oneOf - [ require0 Install.NoArgs - , require1 Install.Install package - ] - in - Terminal.Command "install" Uncommon details example installArgs noFlags Install.run - - - --- PUBLISH - - -publish :: Terminal.Command -publish = - let - details = - "The `publish` command publishes your package on \ - \ so that anyone in the Elm community can use it." - - example = - stack - [ reflow - "Think hard if you are ready to publish NEW packages though!" - , reflow - "Part of what makes Elm great is the packages ecosystem. The fact that\ - \ there is usually one option (usually very well done) makes it way\ - \ easier to pick packages and become productive. So having a million\ - \ packages would be a failure in Elm. We do not need twenty of\ - \ everything, all coded in a single weekend." - , reflow - "So as community members gain wisdom through experience, we want\ - \ them to share that through thoughtful API design and excellent\ - \ documentation. It is more about sharing ideas and insights than\ - \ just sharing code! The first step may be asking for advice from\ - \ people you respect, or in community forums. The second step may\ - \ be using it at work to see if it is as nice as you think. Maybe\ - \ it ends up as an experiment on GitHub only. Point is, try to be\ - \ respectful of the community and package ecosystem!" - , reflow - "Check out for guidance on how to create great packages!" - ] - in - Terminal.Command "publish" Uncommon details example noArgs noFlags Publish.run - - - --- BUMP - - -bump :: Terminal.Command -bump = - let - details = - "The `bump` command figures out the next version number based on API changes:" - - example = - reflow - "Say you just published version 1.0.0, but then decided to remove a function.\ - \ I will compare the published API to what you have locally, figure out that\ - \ it is a MAJOR change, and bump your version number to 2.0.0. I do this with\ - \ all packages, so there cannot be MAJOR changes hiding in PATCH releases in Elm!" - in - Terminal.Command "bump" Uncommon details example noArgs noFlags Bump.run - - - --- DIFF - - -diff :: Terminal.Command -diff = - let - details = - "The `diff` command detects API changes:" - - example = - stack - [ reflow - "For example, to see what changed in the HTML package between\ - \ versions 1.0.0 and 2.0.0, you can say:" - , P.indent 4 $ P.green $ "elm diff elm/html 1.0.0 2.0.0" - , reflow - "Sometimes a MAJOR change is not actually very big, so\ - \ this can help you plan your upgrade timelines." - ] - - diffArgs = - oneOf - [ require0 Diff.CodeVsLatest - , require1 Diff.CodeVsExactly version - , require2 Diff.LocalInquiry version version - , require3 Diff.GlobalInquiry package version version - ] - in - Terminal.Command "diff" Uncommon details example diffArgs noFlags Diff.run - - - --- HELPERS - - -stack :: [P.Doc] -> P.Doc -stack docs = - P.vcat $ List.intersperse "" docs - - -reflow :: String -> P.Doc -reflow string = - P.fillSep $ map P.text $ words string diff --git a/terminal/src/Make.hs b/terminal/src/Make.hs deleted file mode 100644 index 936f050160..0000000000 --- a/terminal/src/Make.hs +++ /dev/null @@ -1,319 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module Make - ( Flags(..) - , Output(..) - , ReportType(..) - , run - , reportType - , output - , docsFile - ) - where - - -import qualified Data.ByteString.Builder as B -import qualified Data.Maybe as Maybe -import qualified Data.NonEmptyList as NE -import qualified System.Directory as Dir -import qualified System.FilePath as FP - -import qualified AST.Optimized as Opt -import qualified BackgroundWriter as BW -import qualified Build -import qualified Elm.Details as Details -import qualified Elm.ModuleName as ModuleName -import qualified File -import qualified Generate -import qualified Generate.Html as Html -import qualified Reporting -import qualified Reporting.Exit as Exit -import qualified Reporting.Task as Task -import qualified Stuff -import Terminal (Parser(..)) - - - --- FLAGS - - -data Flags = - Flags - { _debug :: Bool - , _optimize :: Bool - , _output :: Maybe Output - , _report :: Maybe ReportType - , _docs :: Maybe FilePath - } - - -data Output - = JS FilePath - | Html FilePath - | DevNull - - -data ReportType - = Json - - - --- RUN - - -type Task a = Task.Task Exit.Make a - - -run :: [FilePath] -> Flags -> IO () -run paths flags@(Flags _ _ _ report _) = - do style <- getStyle report - maybeRoot <- Stuff.findRoot - Reporting.attemptWithStyle style Exit.makeToReport $ - case maybeRoot of - Just root -> runHelp root paths style flags - Nothing -> return $ Left $ Exit.MakeNoOutline - - -runHelp :: FilePath -> [FilePath] -> Reporting.Style -> Flags -> IO (Either Exit.Make ()) -runHelp root paths style (Flags debug optimize maybeOutput _ maybeDocs) = - BW.withScope $ \scope -> - Stuff.withRootLock root $ Task.run $ - do desiredMode <- getMode debug optimize - details <- Task.eio Exit.MakeBadDetails (Details.load style scope root) - case paths of - [] -> - do exposed <- getExposed details - buildExposed style root details maybeDocs exposed - - p:ps -> - do artifacts <- buildPaths style root details (NE.List p ps) - case maybeOutput of - Nothing -> - case getMains artifacts of - [] -> - return () - - [name] -> - do builder <- toBuilder root details desiredMode artifacts - generate style "index.html" (Html.sandwich name builder) (NE.List name []) - - name:names -> - do builder <- toBuilder root details desiredMode artifacts - generate style "elm.js" builder (NE.List name names) - - Just DevNull -> - return () - - Just (JS target) -> - case getNoMains artifacts of - [] -> - do builder <- toBuilder root details desiredMode artifacts - generate style target builder (Build.getRootNames artifacts) - - name:names -> - Task.throw (Exit.MakeNonMainFilesIntoJavaScript name names) - - Just (Html target) -> - do name <- hasOneMain artifacts - builder <- toBuilder root details desiredMode artifacts - generate style target (Html.sandwich name builder) (NE.List name []) - - - --- GET INFORMATION - - -getStyle :: Maybe ReportType -> IO Reporting.Style -getStyle report = - case report of - Nothing -> Reporting.terminal - Just Json -> return Reporting.json - - -getMode :: Bool -> Bool -> Task DesiredMode -getMode debug optimize = - case (debug, optimize) of - (True , True ) -> Task.throw Exit.MakeCannotOptimizeAndDebug - (True , False) -> return Debug - (False, False) -> return Dev - (False, True ) -> return Prod - - -getExposed :: Details.Details -> Task (NE.List ModuleName.Raw) -getExposed (Details.Details _ validOutline _ _ _ _) = - case validOutline of - Details.ValidApp _ -> - Task.throw Exit.MakeAppNeedsFileNames - - Details.ValidPkg _ exposed _ -> - case exposed of - [] -> Task.throw Exit.MakePkgNeedsExposing - m:ms -> return (NE.List m ms) - - - --- BUILD PROJECTS - - -buildExposed :: Reporting.Style -> FilePath -> Details.Details -> Maybe FilePath -> NE.List ModuleName.Raw -> Task () -buildExposed style root details maybeDocs exposed = - let - docsGoal = maybe Build.IgnoreDocs Build.WriteDocs maybeDocs - in - Task.eio Exit.MakeCannotBuild $ - Build.fromExposed style root details docsGoal exposed - - -buildPaths :: Reporting.Style -> FilePath -> Details.Details -> NE.List FilePath -> Task Build.Artifacts -buildPaths style root details paths = - Task.eio Exit.MakeCannotBuild $ - Build.fromPaths style root details paths - - - --- GET MAINS - - -getMains :: Build.Artifacts -> [ModuleName.Raw] -getMains (Build.Artifacts _ _ roots modules) = - Maybe.mapMaybe (getMain modules) (NE.toList roots) - - -getMain :: [Build.Module] -> Build.Root -> Maybe ModuleName.Raw -getMain modules root = - case root of - Build.Inside name -> - if any (isMain name) modules - then Just name - else Nothing - - Build.Outside name _ (Opt.LocalGraph maybeMain _ _) -> - case maybeMain of - Just _ -> Just name - Nothing -> Nothing - - -isMain :: ModuleName.Raw -> Build.Module -> Bool -isMain targetName modul = - case modul of - Build.Fresh name _ (Opt.LocalGraph maybeMain _ _) -> - Maybe.isJust maybeMain && name == targetName - - Build.Cached name mainIsDefined _ -> - mainIsDefined && name == targetName - - - --- HAS ONE MAIN - - -hasOneMain :: Build.Artifacts -> Task ModuleName.Raw -hasOneMain (Build.Artifacts _ _ roots modules) = - case roots of - NE.List root [] -> Task.mio Exit.MakeNoMain (return $ getMain modules root) - NE.List _ (_:_) -> Task.throw Exit.MakeMultipleFilesIntoHtml - - - --- GET MAINLESS - - -getNoMains :: Build.Artifacts -> [ModuleName.Raw] -getNoMains (Build.Artifacts _ _ roots modules) = - Maybe.mapMaybe (getNoMain modules) (NE.toList roots) - - -getNoMain :: [Build.Module] -> Build.Root -> Maybe ModuleName.Raw -getNoMain modules root = - case root of - Build.Inside name -> - if any (isMain name) modules - then Nothing - else Just name - - Build.Outside name _ (Opt.LocalGraph maybeMain _ _) -> - case maybeMain of - Just _ -> Nothing - Nothing -> Just name - - - --- GENERATE - - -generate :: Reporting.Style -> FilePath -> B.Builder -> NE.List ModuleName.Raw -> Task () -generate style target builder names = - Task.io $ - do Dir.createDirectoryIfMissing True (FP.takeDirectory target) - File.writeBuilder target builder - Reporting.reportGenerate style names target - - - --- TO BUILDER - - -data DesiredMode = Debug | Dev | Prod - - -toBuilder :: FilePath -> Details.Details -> DesiredMode -> Build.Artifacts -> Task B.Builder -toBuilder root details desiredMode artifacts = - Task.mapError Exit.MakeBadGenerate $ - case desiredMode of - Debug -> Generate.debug root details artifacts - Dev -> Generate.dev root details artifacts - Prod -> Generate.prod root details artifacts - - - --- PARSERS - - -reportType :: Parser ReportType -reportType = - Parser - { _singular = "report type" - , _plural = "report types" - , _parser = \string -> if string == "json" then Just Json else Nothing - , _suggest = \_ -> return ["json"] - , _examples = \_ -> return ["json"] - } - - -output :: Parser Output -output = - Parser - { _singular = "output file" - , _plural = "output files" - , _parser = parseOutput - , _suggest = \_ -> return [] - , _examples = \_ -> return [ "elm.js", "index.html", "/dev/null" ] - } - - -parseOutput :: String -> Maybe Output -parseOutput name - | isDevNull name = Just DevNull - | hasExt ".html" name = Just (Html name) - | hasExt ".js" name = Just (JS name) - | otherwise = Nothing - - -docsFile :: Parser FilePath -docsFile = - Parser - { _singular = "json file" - , _plural = "json files" - , _parser = \name -> if hasExt ".json" name then Just name else Nothing - , _suggest = \_ -> return [] - , _examples = \_ -> return ["docs.json","documentation.json"] - } - - -hasExt :: String -> String -> Bool -hasExt ext path = - FP.takeExtension path == ext && length path > length ext - - -isDevNull :: String -> Bool -isDevNull name = - name == "/dev/null" || name == "NUL" || name == "$null" diff --git a/terminal/src/Publish.hs b/terminal/src/Publish.hs deleted file mode 100644 index 8ca027c0b9..0000000000 --- a/terminal/src/Publish.hs +++ /dev/null @@ -1,540 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module Publish - ( run - ) - where - - -import Control.Exception (bracket_) -import Control.Monad (void) -import qualified Data.List as List -import qualified Data.NonEmptyList as NE -import qualified Data.Utf8 as Utf8 -import qualified System.Directory as Dir -import qualified System.Exit as Exit -import System.FilePath (()) -import qualified System.Info as Info -import qualified System.IO as IO -import qualified System.Process as Process - -import qualified BackgroundWriter as BW -import qualified Build -import qualified Deps.Bump as Bump -import qualified Deps.Diff as Diff -import qualified Deps.Registry as Registry -import qualified Deps.Website as Website -import qualified Elm.Details as Details -import qualified Elm.Docs as Docs -import qualified Elm.Magnitude as M -import qualified Elm.Outline as Outline -import qualified Elm.Package as Pkg -import qualified Elm.Version as V -import qualified File -import qualified Http -import qualified Json.Decode as D -import qualified Json.String as Json -import qualified Reporting -import Reporting.Doc ((<+>)) -import qualified Reporting.Doc as D -import qualified Reporting.Exit as Exit -import qualified Reporting.Exit.Help as Help -import qualified Reporting.Task as Task -import qualified Stuff - - - --- RUN - - --- TODO mandate no "exposing (..)" in packages to make --- optimization to skip builds in Elm.Details always valid - - -run :: () -> () -> IO () -run () () = - Reporting.attempt Exit.publishToReport $ - Task.run $ publish =<< getEnv - - - --- ENV - - -data Env = - Env - { _root :: FilePath - , _cache :: Stuff.PackageCache - , _manager :: Http.Manager - , _registry :: Registry.Registry - , _outline :: Outline.Outline - } - - -getEnv :: Task.Task Exit.Publish Env -getEnv = - do root <- Task.mio Exit.PublishNoOutline $ Stuff.findRoot - cache <- Task.io $ Stuff.getPackageCache - manager <- Task.io $ Http.getManager - registry <- Task.eio Exit.PublishMustHaveLatestRegistry $ Registry.latest manager cache - outline <- Task.eio Exit.PublishBadOutline $ Outline.read root - return $ Env root cache manager registry outline - - - --- PUBLISH - - -publish :: Env -> Task.Task Exit.Publish () -publish env@(Env root _ manager registry outline) = - case outline of - Outline.App _ -> - Task.throw Exit.PublishApplication - - Outline.Pkg (Outline.PkgOutline pkg summary _ vsn exposed _ _ _) -> - do let maybeKnownVersions = Registry.getVersions pkg registry - - reportPublishStart pkg vsn maybeKnownVersions - - if noExposed exposed then Task.throw Exit.PublishNoExposed else return () - if badSummary summary then Task.throw Exit.PublishNoSummary else return () - - verifyReadme root - verifyLicense root - docs <- verifyBuild root - verifyVersion env pkg vsn docs maybeKnownVersions - git <- getGit - commitHash <- verifyTag git manager pkg vsn - verifyNoChanges git commitHash vsn - zipHash <- verifyZip env pkg vsn - - Task.io $ putStrLn "" - register manager pkg vsn docs commitHash zipHash - Task.io $ putStrLn "Success!" - - - --- VERIFY SUMMARY - - -badSummary :: Json.String -> Bool -badSummary summary = - Json.isEmpty summary || Outline.defaultSummary == summary - - -noExposed :: Outline.Exposed -> Bool -noExposed exposed = - case exposed of - Outline.ExposedList modules -> - null modules - - Outline.ExposedDict chunks -> - all (null . snd) chunks - - - --- VERIFY README - - -verifyReadme :: FilePath -> Task.Task Exit.Publish () -verifyReadme root = - reportReadmeCheck $ - do let readmePath = root "README.md" - exists <- File.exists readmePath - case exists of - False -> - return (Left Exit.PublishNoReadme) - - True -> - do size <- IO.withFile readmePath IO.ReadMode IO.hFileSize - if size < 300 - then return (Left Exit.PublishShortReadme) - else return (Right ()) - - - --- VERIFY LICENSE - - -verifyLicense :: FilePath -> Task.Task Exit.Publish () -verifyLicense root = - reportLicenseCheck $ - do let licensePath = root "LICENSE" - exists <- File.exists licensePath - if exists - then return (Right ()) - else return (Left Exit.PublishNoLicense) - - - --- VERIFY BUILD - - -verifyBuild :: FilePath -> Task.Task Exit.Publish Docs.Documentation -verifyBuild root = - reportBuildCheck $ BW.withScope $ \scope -> - Task.run $ - do details@(Details.Details _ outline _ _ _ _) <- - Task.eio Exit.PublishBadDetails $ - Details.load Reporting.silent scope root - - exposed <- - case outline of - Details.ValidApp _ -> Task.throw Exit.PublishApplication - Details.ValidPkg _ [] _ -> Task.throw Exit.PublishNoExposed - Details.ValidPkg _ (e:es) _ -> return (NE.List e es) - - Task.eio Exit.PublishBuildProblem $ - Build.fromExposed Reporting.silent root details Build.KeepDocs exposed - - --- GET GIT - - -newtype Git = - Git { _run :: [String] -> IO Exit.ExitCode } - - -getGit :: Task.Task Exit.Publish Git -getGit = - do maybeGit <- Task.io $ Dir.findExecutable "git" - case maybeGit of - Nothing -> - Task.throw Exit.PublishNoGit - - Just git -> - return $ Git $ \args -> - let - process = - (Process.proc git args) - { Process.std_in = Process.CreatePipe - , Process.std_out = Process.CreatePipe - , Process.std_err = Process.CreatePipe - } - in - Process.withCreateProcess process $ \_ _ _ handle -> - Process.waitForProcess handle - - - --- VERIFY GITHUB TAG - - -verifyTag :: Git -> Http.Manager -> Pkg.Name -> V.Version -> Task.Task Exit.Publish String -verifyTag git manager pkg vsn = - reportTagCheck vsn $ - do -- https://stackoverflow.com/questions/1064499/how-to-list-all-git-tags - exitCode <- _run git [ "show", "--name-only", V.toChars vsn, "--" ] - case exitCode of - Exit.ExitFailure _ -> - return $ Left (Exit.PublishMissingTag vsn) - - Exit.ExitSuccess -> - let url = toTagUrl pkg vsn in - Http.get manager url [Http.accept "application/json"] (Exit.PublishCannotGetTag vsn) $ \body -> - case D.fromByteString commitHashDecoder body of - Right hash -> - return $ Right hash - - Left _ -> - return $ Left (Exit.PublishCannotGetTagData vsn url body) - - -toTagUrl :: Pkg.Name -> V.Version -> String -toTagUrl pkg vsn = - "https://api.github.com/repos/" ++ Pkg.toUrl pkg ++ "/git/refs/tags/" ++ V.toChars vsn - - -commitHashDecoder :: D.Decoder e String -commitHashDecoder = - Utf8.toChars <$> - D.field "object" (D.field "sha" D.string) - - - --- VERIFY NO LOCAL CHANGES SINCE TAG - - -verifyNoChanges :: Git -> String -> V.Version -> Task.Task Exit.Publish () -verifyNoChanges git commitHash vsn = - reportLocalChangesCheck $ - do -- https://stackoverflow.com/questions/3878624/how-do-i-programmatically-determine-if-there-are-uncommited-changes - exitCode <- _run git [ "diff-index", "--quiet", commitHash, "--" ] - case exitCode of - Exit.ExitSuccess -> return $ Right () - Exit.ExitFailure _ -> return $ Left (Exit.PublishLocalChanges vsn) - - - --- VERIFY THAT ZIP BUILDS / COMPUTE HASH - - -verifyZip :: Env -> Pkg.Name -> V.Version -> Task.Task Exit.Publish Http.Sha -verifyZip (Env root _ manager _ _) pkg vsn = - withPrepublishDir root $ \prepublishDir -> - do let url = toZipUrl pkg vsn - - (sha, archive) <- - reportDownloadCheck $ - Http.getArchive manager url - Exit.PublishCannotGetZip - (Exit.PublishCannotDecodeZip url) - (return . Right) - - Task.io $ File.writePackage prepublishDir archive - - reportZipBuildCheck $ - Dir.withCurrentDirectory prepublishDir $ - verifyZipBuild prepublishDir - - return sha - - -toZipUrl :: Pkg.Name -> V.Version -> String -toZipUrl pkg vsn = - "https://github.com/" ++ Pkg.toUrl pkg ++ "/zipball/" ++ V.toChars vsn ++ "/" - - -withPrepublishDir :: FilePath -> (FilePath -> Task.Task x a) -> Task.Task x a -withPrepublishDir root callback = - let - dir = Stuff.prepublishDir root - in - Task.eio id $ - bracket_ - (Dir.createDirectoryIfMissing True dir) - (Dir.removeDirectoryRecursive dir) - (Task.run (callback dir)) - - -verifyZipBuild :: FilePath -> IO (Either Exit.Publish ()) -verifyZipBuild root = - BW.withScope $ \scope -> Task.run $ - do details@(Details.Details _ outline _ _ _ _) <- - Task.eio Exit.PublishZipBadDetails $ - Details.load Reporting.silent scope root - - exposed <- - case outline of - Details.ValidApp _ -> Task.throw Exit.PublishZipApplication - Details.ValidPkg _ [] _ -> Task.throw Exit.PublishZipNoExposed - Details.ValidPkg _ (e:es) _ -> return (NE.List e es) - - _ <- Task.eio Exit.PublishZipBuildProblem $ - Build.fromExposed Reporting.silent root details Build.KeepDocs exposed - - return () - - - --- VERIFY VERSION - - -data GoodVersion - = GoodStart - | GoodBump V.Version M.Magnitude - - -verifyVersion :: Env -> Pkg.Name -> V.Version -> Docs.Documentation -> Maybe Registry.KnownVersions -> Task.Task Exit.Publish () -verifyVersion env pkg vsn newDocs publishedVersions = - reportSemverCheck vsn $ - case publishedVersions of - Nothing -> - if vsn == V.one - then return $ Right GoodStart - else return $ Left $ Exit.PublishNotInitialVersion vsn - - Just knownVersions@(Registry.KnownVersions latest previous) -> - if vsn == latest || elem vsn previous - then return $ Left $ Exit.PublishAlreadyPublished vsn - else verifyBump env pkg vsn newDocs knownVersions - - -verifyBump :: Env -> Pkg.Name -> V.Version -> Docs.Documentation -> Registry.KnownVersions -> IO (Either Exit.Publish GoodVersion) -verifyBump (Env _ cache manager _ _) pkg vsn newDocs knownVersions@(Registry.KnownVersions latest _) = - case List.find (\(_ ,new, _) -> vsn == new) (Bump.getPossibilities knownVersions) of - Nothing -> - return $ Left $ - Exit.PublishInvalidBump vsn latest - - Just (old, new, magnitude) -> - do result <- Diff.getDocs cache manager pkg old - case result of - Left dp -> - return $ Left $ Exit.PublishCannotGetDocs old new dp - - Right oldDocs -> - let - changes = Diff.diff oldDocs newDocs - realNew = Diff.bump changes old - in - if new == realNew - then return $ Right $ GoodBump old magnitude - else - return $ Left $ - Exit.PublishBadBump old new magnitude realNew (Diff.toMagnitude changes) - - - --- REGISTER PACKAGES - - -register :: Http.Manager -> Pkg.Name -> V.Version -> Docs.Documentation -> String -> Http.Sha -> Task.Task Exit.Publish () -register manager pkg vsn docs commitHash sha = - let - url = - Website.route "/register" - [ ("name", Pkg.toChars pkg) - , ("version", V.toChars vsn) - , ("commit-hash", commitHash) - ] - in - Task.eio Exit.PublishCannotRegister $ - Http.upload manager url - [ Http.filePart "elm.json" "elm.json" - , Http.jsonPart "docs.json" "docs.json" (Docs.encode docs) - , Http.filePart "README.md" "README.md" - , Http.stringPart "github-hash" (Http.shaToChars sha) - ] - - - --- REPORTING - - -reportPublishStart :: Pkg.Name -> V.Version -> Maybe Registry.KnownVersions -> Task.Task x () -reportPublishStart pkg vsn maybeKnownVersions = - Task.io $ - case maybeKnownVersions of - Nothing -> - putStrLn $ Exit.newPackageOverview ++ "\nI will now verify that everything is in order...\n" - - Just _ -> - putStrLn $ "Verifying " ++ Pkg.toChars pkg ++ " " ++ V.toChars vsn ++ " ...\n" - - - --- REPORTING PHASES - - -reportReadmeCheck :: IO (Either x a) -> Task.Task x a -reportReadmeCheck = - reportCheck - "Looking for README.md" - "Found README.md" - "Problem with your README.md" - - -reportLicenseCheck :: IO (Either x a) -> Task.Task x a -reportLicenseCheck = - reportCheck - "Looking for LICENSE" - "Found LICENSE" - "Problem with your LICENSE" - - -reportBuildCheck :: IO (Either x a) -> Task.Task x a -reportBuildCheck = - reportCheck - "Verifying documentation..." - "Verified documentation" - "Problem with documentation" - - -reportSemverCheck :: V.Version -> IO (Either x GoodVersion) -> Task.Task x () -reportSemverCheck version work = - let - vsn = V.toChars version - - waiting = "Checking semantic versioning rules. Is " ++ vsn ++ " correct?" - failure = "Version " ++ vsn ++ " is not correct!" - success result = - case result of - GoodStart -> - "All packages start at version " ++ V.toChars V.one - - GoodBump oldVersion magnitude -> - "Version number " ++ vsn ++ " verified (" - ++ M.toChars magnitude ++ " change, " - ++ V.toChars oldVersion ++ " => " ++ vsn ++ ")" - in - void $ reportCustomCheck waiting success failure work - - -reportTagCheck :: V.Version -> IO (Either x a) -> Task.Task x a -reportTagCheck vsn = - reportCheck - ("Is version " ++ V.toChars vsn ++ " tagged on GitHub?") - ("Version " ++ V.toChars vsn ++ " is tagged on GitHub") - ("Version " ++ V.toChars vsn ++ " is not tagged on GitHub!") - - -reportDownloadCheck :: IO (Either x a) -> Task.Task x a -reportDownloadCheck = - reportCheck - "Downloading code from GitHub..." - "Code downloaded successfully from GitHub" - "Could not download code from GitHub!" - - -reportLocalChangesCheck :: IO (Either x a) -> Task.Task x a -reportLocalChangesCheck = - reportCheck - "Checking for uncommitted changes..." - "No uncommitted changes in local code" - "Your local code is different than the code tagged on GitHub" - - -reportZipBuildCheck :: IO (Either x a) -> Task.Task x a -reportZipBuildCheck = - reportCheck - "Verifying downloaded code..." - "Downloaded code compiles successfully" - "Cannot compile downloaded code!" - - -reportCheck :: String -> String -> String -> IO (Either x a) -> Task.Task x a -reportCheck waiting success failure work = - reportCustomCheck waiting (\_ -> success) failure work - - -reportCustomCheck :: String -> (a -> String) -> String -> IO (Either x a) -> Task.Task x a -reportCustomCheck waiting success failure work = - let - putFlush doc = - Help.toStdout doc >> IO.hFlush IO.stdout - - padded message = - message ++ replicate (length waiting - length message) ' ' - in - Task.eio id $ - do putFlush $ " " <> waitingMark <+> D.fromChars waiting - result <- work - putFlush $ - case result of - Right a -> "\r " <> goodMark <+> D.fromChars (padded (success a) ++ "\n") - Left _ -> "\r " <> badMark <+> D.fromChars (padded failure ++ "\n\n") - - return result - - --- MARKS - - -goodMark :: D.Doc -goodMark = - D.green $ if isWindows then "+" else "●" - - -badMark :: D.Doc -badMark = - D.red $ if isWindows then "X" else "✗" - - -waitingMark :: D.Doc -waitingMark = - D.dullyellow $ if isWindows then "-" else "→" - - -isWindows :: Bool -isWindows = - Info.os == "mingw32" diff --git a/terminal/src/Repl.hs b/terminal/src/Repl.hs deleted file mode 100644 index 45f471b171..0000000000 --- a/terminal/src/Repl.hs +++ /dev/null @@ -1,726 +0,0 @@ -{-# OPTIONS_GHC -Wall -fno-warn-name-shadowing #-} -{-# LANGUAGE OverloadedStrings #-} -module Repl - ( Flags(..) - , run - -- - , Lines(..) - , Input(..) - , Prefill(..) - , CategorizedInput(..) - , categorize - -- - , State(..) - , Output(..) - , toByteString - ) - where - - -import Prelude hiding (lines, read) -import Control.Applicative ((<|>)) -import Control.Monad.Trans (lift, liftIO) -import qualified Control.Monad.State.Strict as State -import qualified Data.ByteString as BS -import qualified Data.ByteString.Builder as B -import qualified Data.ByteString.Char8 as BSC -import qualified Data.ByteString.Lazy as LBS -import qualified Data.ByteString.UTF8 as BS_UTF8 -import qualified Data.Char as Char -import qualified Data.List as List -import qualified Data.Map as Map -import Data.Monoid ((<>)) -import qualified Data.Name as N -import qualified System.Console.Haskeline as Repl -import qualified System.Directory as Dir -import qualified System.Exit as Exit -import System.FilePath (()) -import qualified System.IO as IO -import qualified System.Process as Proc - -import qualified AST.Source as Src -import qualified BackgroundWriter as BW -import qualified Build -import qualified Elm.Constraint as C -import qualified Elm.Details as Details -import qualified Elm.Licenses as Licenses -import qualified Elm.ModuleName as ModuleName -import qualified Elm.Outline as Outline -import qualified Elm.Package as Pkg -import qualified Elm.Version as V -import qualified Generate -import qualified Parse.Expression as PE -import qualified Parse.Declaration as PD -import qualified Parse.Module as PM -import qualified Parse.Primitives as P -import qualified Parse.Space as PS -import qualified Parse.Type as PT -import qualified Parse.Variable as PV -import Parse.Primitives (Row, Col) -import qualified Reporting -import qualified Reporting.Annotation as A -import Reporting.Doc ((<+>)) -import qualified Reporting.Doc as D -import qualified Reporting.Error.Syntax as ES -import qualified Reporting.Exit as Exit -import qualified Reporting.Render.Code as Code -import qualified Reporting.Report as Report -import qualified Reporting.Task as Task -import qualified Stuff - - - --- RUN - - -data Flags = - Flags - { _maybeInterpreter :: Maybe FilePath - , _noColors :: Bool - } - - -run :: () -> Flags -> IO () -run () flags = - do printWelcomeMessage - settings <- initSettings - env <- initEnv flags - let looper = Repl.runInputT settings (Repl.withInterrupt (loop env initialState)) - exitCode <- State.evalStateT looper initialState - Exit.exitWith exitCode - - - --- WELCOME - - -printWelcomeMessage :: IO () -printWelcomeMessage = - let - vsn = V.toChars V.compiler - title = "Elm" <+> D.fromChars vsn - dashes = replicate (70 - length vsn) '-' - in - D.toAnsi IO.stdout $ - D.vcat - [ D.black "----" <+> D.dullcyan title <+> D.black (D.fromChars dashes) - , D.black $ D.fromChars $ "Say :help for help and :exit to exit! More at " <> D.makeLink "repl" - , D.black "--------------------------------------------------------------------------------" - , D.empty - ] - - - --- ENV - - -data Env = - Env - { _root :: FilePath - , _interpreter :: FilePath - , _ansi :: Bool - } - - -initEnv :: Flags -> IO Env -initEnv (Flags maybeAlternateInterpreter noColors) = - do root <- getRoot - interpreter <- getInterpreter maybeAlternateInterpreter - return $ Env root interpreter (not noColors) - - - --- LOOP - - -data Outcome - = Loop State - | End Exit.ExitCode - - -type M = - State.StateT State IO - - -loop :: Env -> State -> Repl.InputT M Exit.ExitCode -loop env state = - do input <- Repl.handleInterrupt (return Skip) read - outcome <- liftIO (eval env state input) - case outcome of - Loop state -> - do lift (State.put state) - loop env state - - End exitCode -> - return exitCode - - - --- READ - - -data Input - = Import ModuleName.Raw BS.ByteString - | Type N.Name BS.ByteString - | Port - | Decl N.Name BS.ByteString - | Expr BS.ByteString - -- - | Reset - | Exit - | Skip - | Help (Maybe String) - - -read :: Repl.InputT M Input -read = - do maybeLine <- Repl.getInputLine "> " - case maybeLine of - Nothing -> - return Exit - - Just chars -> - let - lines = Lines (stripLegacyBackslash chars) [] - in - case categorize lines of - Done input -> return input - Continue p -> readMore lines p - - -readMore :: Lines -> Prefill -> Repl.InputT M Input -readMore previousLines prefill = - do input <- Repl.getInputLineWithInitial "| " (renderPrefill prefill, "") - case input of - Nothing -> - return Skip - - Just chars -> - let - lines = addLine (stripLegacyBackslash chars) previousLines - in - case categorize lines of - Done input -> return input - Continue p -> readMore lines p - - --- For compatibility with 0.19.0 such that readers of "Programming Elm" by @jfairbank --- can get through the REPL section successfully. --- --- TODO: remove stripLegacyBackslash in next MAJOR release --- -stripLegacyBackslash :: [Char] -> [Char] -stripLegacyBackslash chars = - case chars of - [] -> - [] - - _:_ -> - if last chars == '\\' - then init chars - else chars - - -data Prefill - = Indent - | DefStart N.Name - - -renderPrefill :: Prefill -> String -renderPrefill lineStart = - case lineStart of - Indent -> - " " - - DefStart name -> - N.toChars name ++ " " - - - --- LINES - - -data Lines = - Lines - { _prevLine :: String - , _revLines :: [String] - } - - -addLine :: [Char] -> Lines -> Lines -addLine line (Lines x xs) = - Lines line (x:xs) - - -isBlank :: Lines -> Bool -isBlank (Lines prev rev) = - null rev && all (==' ') prev - - -isSingleLine :: Lines -> Bool -isSingleLine (Lines _ rev) = - null rev - - -endsWithBlankLine :: Lines -> Bool -endsWithBlankLine (Lines prev _) = - all (==' ') prev - - -linesToByteString :: Lines -> BS_UTF8.ByteString -linesToByteString (Lines prev rev) = - BS_UTF8.fromString (unlines (reverse (prev:rev))) - - -getFirstLine :: Lines -> String -getFirstLine (Lines x xs) = - case xs of - [] -> x - y:ys -> getFirstLine (Lines y ys) - - - - --- CATEGORIZE INPUT - - -data CategorizedInput - = Done Input - | Continue Prefill - - -categorize :: Lines -> CategorizedInput -categorize lines - | isBlank lines = Done Skip - | startsWithColon lines = Done (toCommand lines) - | startsWithKeyword "import" lines = attemptImport lines - | otherwise = attemptDeclOrExpr lines - - -attemptImport :: Lines -> CategorizedInput -attemptImport lines = - let - src = linesToByteString lines - parser = P.specialize (\_ _ _ -> ()) PM.chompImport - in - case P.fromByteString parser (\_ _ -> ()) src of - Right (Src.Import (A.At _ name) _ _) -> - Done (Import name src) - - Left () -> - ifFail lines (Import "ERR" src) - - -ifFail :: Lines -> Input -> CategorizedInput -ifFail lines input = - if endsWithBlankLine lines - then Done input - else Continue Indent - - -ifDone :: Lines -> Input -> CategorizedInput -ifDone lines input = - if isSingleLine lines || endsWithBlankLine lines - then Done input - else Continue Indent - - -attemptDeclOrExpr :: Lines -> CategorizedInput -attemptDeclOrExpr lines = - let - src = linesToByteString lines - exprParser = P.specialize (toExprPosition src) PE.expression - declParser = P.specialize (toDeclPosition src) PD.declaration - in - case P.fromByteString declParser (,) src of - Right (decl, _) -> - case decl of - PD.Value _ (A.At _ (Src.Value (A.At _ name) _ _ _)) -> ifDone lines (Decl name src) - PD.Union _ (A.At _ (Src.Union (A.At _ name) _ _ )) -> ifDone lines (Type name src) - PD.Alias _ (A.At _ (Src.Alias (A.At _ name) _ _ )) -> ifDone lines (Type name src) - PD.Port _ _ -> Done Port - - Left declPosition - | startsWithKeyword "type" lines -> - ifFail lines (Type "ERR" src) - - | startsWithKeyword "port" lines -> - Done Port - - | otherwise -> - case P.fromByteString exprParser (,) src of - Right _ -> - ifDone lines (Expr src) - - Left exprPosition -> - if exprPosition >= declPosition then - ifFail lines (Expr src) - else - case P.fromByteString annotation (\_ _ -> ()) src of - Right name -> Continue (DefStart name) - Left () -> ifFail lines (Decl "ERR" src) - - -startsWithColon :: Lines -> Bool -startsWithColon lines = - case dropWhile (==' ') (getFirstLine lines) of - [] -> False - c:_ -> c == ':' - - -toCommand :: Lines -> Input -toCommand lines = - case drop 1 $ dropWhile (==' ') (getFirstLine lines) of - "reset" -> Reset - "exit" -> Exit - "quit" -> Exit - "help" -> Help Nothing - rest -> Help (Just (takeWhile (/=' ') rest)) - - -startsWithKeyword :: [Char] -> Lines -> Bool -startsWithKeyword keyword lines = - let - line = getFirstLine lines - in - List.isPrefixOf keyword line && - case drop (length keyword) line of - [] -> True - c:_ -> not (Char.isAlphaNum c) - - -toExprPosition :: BS.ByteString -> ES.Expr -> Row -> Col -> (Row, Col) -toExprPosition src expr row col = - let - decl = ES.DeclDef N.replValueToPrint (ES.DeclDefBody expr row col) row col - in - toDeclPosition src decl row col - - -toDeclPosition :: BS.ByteString -> ES.Decl -> Row -> Col -> (Row, Col) -toDeclPosition src decl r c = - let - err = ES.ParseError (ES.Declarations decl r c) - report = ES.toReport (Code.toSource src) err - - (Report.Report _ (A.Region (A.Position row col) _) _ _) = report - in - (row, col) - - -annotation :: P.Parser () N.Name -annotation = - let - err _ _ = () - err_ _ _ _ = () - in - do name <- PV.lower err - PS.chompAndCheckIndent err_ err - P.word1 0x3A {-:-} err - PS.chompAndCheckIndent err_ err - (_, _) <- P.specialize err_ PT.expression - PS.checkFreshLine err - return name - - - --- STATE - - -data State = - State - { _imports :: Map.Map N.Name B.Builder - , _types :: Map.Map N.Name B.Builder - , _decls :: Map.Map N.Name B.Builder - } - - -initialState :: State -initialState = - State Map.empty Map.empty Map.empty - - - --- EVAL - - -eval :: Env -> State -> Input -> IO Outcome -eval env state@(State imports types decls) input = - Repl.handleInterrupt (putStrLn "" >> return (Loop state)) $ - case input of - Skip -> - return (Loop state) - - Exit -> - return (End Exit.ExitSuccess) - - Reset -> - do putStrLn "" - return (Loop initialState) - - Help maybeUnknownCommand -> - do putStrLn (toHelpMessage maybeUnknownCommand) - return (Loop state) - - Import name src -> - do let newState = state { _imports = Map.insert name (B.byteString src) imports } - Loop <$> attemptEval env state newState OutputNothing - - Type name src -> - do let newState = state { _types = Map.insert name (B.byteString src) types } - Loop <$> attemptEval env state newState OutputNothing - - Port -> - do putStrLn "I cannot handle port declarations." - return (Loop state) - - Decl name src -> - do let newState = state { _decls = Map.insert name (B.byteString src) decls } - Loop <$> attemptEval env state newState (OutputDecl name) - - Expr src -> - Loop <$> attemptEval env state state (OutputExpr src) - - - --- ATTEMPT EVAL - - -data Output - = OutputNothing - | OutputDecl N.Name - | OutputExpr BS.ByteString - - -attemptEval :: Env -> State -> State -> Output -> IO State -attemptEval (Env root interpreter ansi) oldState newState output = - do result <- - BW.withScope $ \scope -> - Stuff.withRootLock root $ Task.run $ - do details <- - Task.eio Exit.ReplBadDetails $ - Details.load Reporting.silent scope root - - artifacts <- - Task.eio id $ - Build.fromRepl root details (toByteString newState output) - - traverse (Task.mapError Exit.ReplBadGenerate . Generate.repl root details ansi artifacts) (toPrintName output) - - case result of - Left exit -> - do Exit.toStderr (Exit.replToReport exit) - return oldState - - Right Nothing -> - return newState - - Right (Just javascript) -> - do exitCode <- interpret interpreter javascript - case exitCode of - Exit.ExitSuccess -> return newState - Exit.ExitFailure _ -> return oldState - - -interpret :: FilePath -> B.Builder -> IO Exit.ExitCode -interpret interpreter javascript = - let - createProcess = (Proc.proc interpreter []) { Proc.std_in = Proc.CreatePipe } - in - Proc.withCreateProcess createProcess $ \(Just stdin) _ _ handle -> - do B.hPutBuilder stdin javascript - IO.hClose stdin - Proc.waitForProcess handle - - - --- TO BYTESTRING - - -toByteString :: State -> Output -> BS.ByteString -toByteString (State imports types decls) output = - LBS.toStrict $ B.toLazyByteString $ - mconcat - [ "module ", N.toBuilder N.replModule, " exposing (..)\n" - , Map.foldr mappend mempty imports - , Map.foldr mappend mempty types - , Map.foldr mappend mempty decls - , outputToBuilder output - ] - - -outputToBuilder :: Output -> B.Builder -outputToBuilder output = - N.toBuilder N.replValueToPrint <> " =" <> - case output of - OutputNothing -> - " ()\n" - - OutputDecl _ -> - " ()\n" - - OutputExpr expr -> - foldr (\line rest -> "\n " <> B.byteString line <> rest) "\n" (BSC.lines expr) - - - --- TO PRINT NAME - - -toPrintName :: Output -> Maybe N.Name -toPrintName output = - case output of - OutputNothing -> Nothing - OutputDecl name -> Just name - OutputExpr _ -> Just N.replValueToPrint - - - --- HELP MESSAGES - - -toHelpMessage :: Maybe String -> String -toHelpMessage maybeBadCommand = - case maybeBadCommand of - Nothing -> - genericHelpMessage - - Just command -> - "I do not recognize the :" ++ command ++ " command. " ++ genericHelpMessage - - -genericHelpMessage :: String -genericHelpMessage = - "Valid commands include:\n\ - \\n\ - \ :exit Exit the REPL\n\ - \ :help Show this information\n\ - \ :reset Clear all previous imports and definitions\n\ - \\n\ - \More info at " ++ D.makeLink "repl" ++ "\n" - - - --- GET ROOT - - -getRoot :: IO FilePath -getRoot = - do maybeRoot <- Stuff.findRoot - case maybeRoot of - Just root -> - return root - - Nothing -> - do cache <- Stuff.getReplCache - let root = cache "tmp" - Dir.createDirectoryIfMissing True (root "src") - Outline.write root $ Outline.Pkg $ - Outline.PkgOutline - Pkg.dummyName - Outline.defaultSummary - Licenses.bsd3 - V.one - (Outline.ExposedList []) - defaultDeps - Map.empty - C.defaultElm - - return root - - -defaultDeps :: Map.Map Pkg.Name C.Constraint -defaultDeps = - Map.fromList - [ (Pkg.core, C.anything) - , (Pkg.json, C.anything) - , (Pkg.html, C.anything) - ] - - - --- GET INTERPRETER - - -getInterpreter :: Maybe String -> IO FilePath -getInterpreter maybeName = - case maybeName of - Just name -> - getInterpreterHelp name (Dir.findExecutable name) - - Nothing -> - getInterpreterHelp "node` or `nodejs" $ - do exe1 <- Dir.findExecutable "node" - exe2 <- Dir.findExecutable "nodejs" - return (exe1 <|> exe2) - - -getInterpreterHelp :: String -> IO (Maybe FilePath) -> IO FilePath -getInterpreterHelp name findExe = - do maybePath <- findExe - case maybePath of - Just path -> - return path - - Nothing -> - do IO.hPutStrLn IO.stderr (exeNotFound name) - Exit.exitFailure - - -exeNotFound :: String -> String -exeNotFound name = - "The REPL relies on node.js to execute JavaScript code outside the browser.\n" - ++ "I could not find executable `" ++ name ++ "` on your PATH though!\n\n" - ++ "You can install node.js from . If it is already installed\n" - ++ "but has a different name, use the --interpreter flag." - - - --- SETTINGS - - -initSettings :: IO (Repl.Settings M) -initSettings = - do cache <- Stuff.getReplCache - return $ - Repl.Settings - { Repl.historyFile = Just (cache "history") - , Repl.autoAddHistory = True - , Repl.complete = Repl.completeWord Nothing " \n" lookupCompletions - } - - -lookupCompletions :: String -> M [Repl.Completion] -lookupCompletions string = - do (State imports types decls) <- State.get - return $ - addMatches string False decls $ - addMatches string False types $ - addMatches string True imports $ - addMatches string False commands [] - - -commands :: Map.Map N.Name () -commands = - Map.fromList - [ (":exit", ()) - , (":quit", ()) - , (":reset", ()) - , (":help", ()) - ] - - -addMatches :: String -> Bool -> Map.Map N.Name v -> [Repl.Completion] -> [Repl.Completion] -addMatches string isFinished dict completions = - Map.foldrWithKey (addMatch string isFinished) completions dict - - -addMatch :: String -> Bool -> N.Name -> v -> [Repl.Completion] -> [Repl.Completion] -addMatch string isFinished name _ completions = - let - suggestion = N.toChars name - in - if List.isPrefixOf string suggestion then - Repl.Completion suggestion suggestion isFinished : completions - else - completions diff --git a/tests/Common/FormatTests.elm b/tests/Common/FormatTests.elm new file mode 100644 index 0000000000..063206da1a --- /dev/null +++ b/tests/Common/FormatTests.elm @@ -0,0 +1,62 @@ +module Common.FormatTests exposing (suite) + +import Common.Format +import Compiler.Elm.Package as Pkg +import Compiler.Parse.Module as M +import Compiler.Parse.SyntaxVersion as SV +import Expect +import Test exposing (Test) + + +suite : Test +suite = + Test.describe "Common.Format.format" + [ Test.describe "fromByteString" + [ Test.test "Header" <| + \_ -> + Common.Format.format SV.Guida (M.Package Pkg.core) (generateModule defaultModule) + |> Expect.equal (Ok "module Main exposing (..)\n\n\nfn =\n ()\n") + , Test.test "Records" <| + \_ -> + Common.Format.format SV.Guida + (M.Package Pkg.core) + (generateModule + { defaultModule + | declarations = + [ "fn = { {- C1 -} a {- C2 -} = {- C3 -} 1 {- C4 -}, {- C5 -} b {- C6 -} = {- C7 -} { {- C8 -} M.b {- C9 -} | {- C10 -} x {- C11 -} = {- C12 -} 2 {- C13 -} }, {- C14 -} c {- C15 -} = {- C16 -} { {- C17 -} defaultC {- C18 -} | {- C19 -} y {- C20 -} = {- C21 -} 3 {- C22 -} } {- C23 -} }" + ] + } + ) + |> Expect.equal (Ok "module Main exposing (..)\n\n\nfn =\n { {- C1 -} a {- C2 -} = {- C3 -} 1\n\n {- C4 -}\n , {- C5 -}\n b {- C6 -} =\n {- C7 -}\n { {- C8 -} M.b {- C9 -}\n | {- C10 -} x {- C11 -} = {- C12 -} 2\n\n {- C13 -}\n }\n , {- C14 -}\n c {- C15 -} =\n {- C16 -}\n { {- C17 -} defaultC {- C18 -}\n | {- C19 -} y {- C20 -} = {- C21 -} 3\n\n {- C22 -}\n }\n\n {- C23 -}\n }\n") + ] + ] + + +type alias GenerateModuleConfig = + { header : String + , docs : String + , imports : List String + , infixes : List String + , declarations : List String + } + + +defaultModule : GenerateModuleConfig +defaultModule = + { header = "module Main exposing (..)" + , docs = "" + , imports = [] + , infixes = [] + , declarations = [ "fn = ()" ] + } + + +generateModule : GenerateModuleConfig -> String +generateModule { header, docs, imports, infixes, declarations } = + String.join "\n" + [ header + , docs + , String.join "\n" imports + , String.join "\n" infixes + , String.join "\n" declarations + ] diff --git a/tests/Parse/ModuleTests.elm b/tests/Parse/ModuleTests.elm new file mode 100644 index 0000000000..9bc12c0621 --- /dev/null +++ b/tests/Parse/ModuleTests.elm @@ -0,0 +1,68 @@ +module Parse.ModuleTests exposing (suite) + +import Compiler.AST.Source as S +import Compiler.Parse.Module as M +import Compiler.Parse.SyntaxVersion as SV +import Compiler.Reporting.Annotation as A +import Expect +import Test exposing (Test) + + +suite : Test +suite = + Test.describe "Parse.Module" + [ Test.describe "fromByteString" + [ Test.test "Hello!" <| + \_ -> + M.fromByteString SV.Elm M.Application """module Hello exposing (..) + +import Html exposing (text) + + +main = + text "Hello!" + """ + |> Expect.equal + (Ok + (S.Module + SV.Elm + (Just (A.at (A.Position 1 8) (A.Position 1 13) "Hello")) + (A.at (A.Position 1 23) (A.Position 1 27) (S.Open [] [])) + (S.NoDocs (A.Region (A.Position 1 27) (A.Position 3 1)) []) + [ S.Import ( [], A.At A.zero "Platform.Sub" ) (Just ( ( [], [] ), "Sub" )) ( ( [], [] ), S.Explicit (A.At A.zero [ ( ( [], [] ), S.Upper (A.At A.zero "Sub") ( [], S.Private ) ) ]) ) + , S.Import ( [], A.At A.zero "Platform.Cmd" ) (Just ( ( [], [] ), "Cmd" )) ( ( [], [] ), S.Explicit (A.At A.zero [ ( ( [], [] ), S.Upper (A.At A.zero "Cmd") ( [], S.Private ) ) ]) ) + , S.Import ( [], A.At A.zero "Platform" ) Nothing ( ( [], [] ), S.Explicit (A.At A.zero [ ( ( [], [] ), S.Upper (A.At A.zero "Program") ( [], S.Private ) ) ]) ) + , S.Import ( [], A.At A.zero "Tuple" ) Nothing ( ( [], [] ), S.Explicit (A.At A.zero []) ) + , S.Import ( [], A.At A.zero "Char" ) Nothing ( ( [], [] ), S.Explicit (A.At A.zero [ ( ( [], [] ), S.Upper (A.At A.zero "Char") ( [], S.Private ) ) ]) ) + , S.Import ( [], A.At A.zero "String" ) Nothing ( ( [], [] ), S.Explicit (A.At A.zero [ ( ( [], [] ), S.Upper (A.At A.zero "String") ( [], S.Private ) ) ]) ) + , S.Import ( [], A.At A.zero "Result" ) Nothing ( ( [], [] ), S.Explicit (A.At A.zero [ ( ( [], [] ), S.Upper (A.At A.zero "Result") ( [], S.Public (A.Region (A.Position 0 0) (A.Position 0 0)) ) ) ]) ) + , S.Import ( [], A.At A.zero "Maybe" ) Nothing ( ( [], [] ), S.Explicit (A.At A.zero [ ( ( [], [] ), S.Upper (A.At A.zero "Maybe") ( [], S.Public (A.Region (A.Position 0 0) (A.Position 0 0)) ) ) ]) ) + , S.Import ( [], A.At A.zero "List" ) Nothing ( ( [], [] ), S.Explicit (A.At A.zero [ ( ( [], [] ), S.Operator (A.Region (A.Position 0 0) (A.Position 0 0)) "::" ) ]) ) + , S.Import ( [], A.At A.zero "Debug" ) Nothing ( ( [], [] ), S.Explicit (A.At A.zero []) ) + , S.Import ( [], A.At A.zero "Basics" ) Nothing ( ( [], [] ), S.Open [] [] ) + , S.Import ( [], A.at (A.Position 3 8) (A.Position 3 12) "Html" ) Nothing ( ( [], [] ), S.Explicit (A.at (A.Position 3 23) (A.Position 3 28) [ ( ( [], [] ), S.Lower (A.at (A.Position 3 23) (A.Position 3 27) "text") ) ]) ) + ] + [ A.at (A.Position 6 1) + (A.Position 7 16) + (S.Value [] + ( [], A.at (A.Position 6 1) (A.Position 6 5) "main" ) + [] + ( [] + , A.at (A.Position 7 3) + (A.Position 7 16) + (S.Call (A.at (A.Position 7 3) (A.Position 7 7) (S.Var S.LowVar "text")) + [ ( [], A.at (A.Position 7 8) (A.Position 7 16) (S.Str "Hello!" False) ) + ] + ) + ) + Nothing + ) + ] + [] + [] + [] + S.NoEffects + ) + ) + ] + ] diff --git a/tests/Parse/NumberTests.elm b/tests/Parse/NumberTests.elm new file mode 100644 index 0000000000..6453229f37 --- /dev/null +++ b/tests/Parse/NumberTests.elm @@ -0,0 +1,254 @@ +module Parse.NumberTests exposing (suite) + +import Compiler.Parse.Number as N +import Compiler.Parse.Primitives as P +import Compiler.Parse.SyntaxVersion as SyntaxVersion exposing (SyntaxVersion) +import Compiler.Reporting.Error.Syntax as E +import Expect +import Test exposing (Test) + + +suite : Test +suite = + Test.describe "Parse.Number" + [ Test.describe "Guida" + [ Test.describe "Int" + [ Test.test "No underscores 1000" <| + \_ -> + singleNumber SyntaxVersion.Guida "1000" + |> Expect.equal (Ok (N.Int 1000 "1000")) + , Test.test "One underscore 1_000" <| + \_ -> + singleNumber SyntaxVersion.Guida "1_000" + |> Expect.equal (Ok (N.Int 1000 "1_000")) + , Test.test "One underscore 42_000" <| + \_ -> + singleNumber SyntaxVersion.Guida "42_000" + |> Expect.equal (Ok (N.Int 42000 "42_000")) + , Test.test "Multiple underscores 2_000_000" <| + \_ -> + singleNumber SyntaxVersion.Guida "2_000_000" + |> Expect.equal (Ok (N.Int 2000000 "2_000_000")) + , Test.test "Consecutive underscores: '42__000' should fail at position 4" <| + \_ -> + expectErrAtPosition 4 SyntaxVersion.Guida "42__000" E.NumberNoConsecutiveUnderscores + , Test.test "Leading underscore: '_42_000' should fail at position 1" <| + \_ -> + expectErrAtPosition 1 SyntaxVersion.Guida "_42_000" E.NumberNoLeadingOrTrailingUnderscores + , Test.test "Trailing underscore: '42_000_' should fail at position 7" <| + \_ -> + expectErrAtPosition 7 SyntaxVersion.Guida "42_000_" E.NumberNoLeadingOrTrailingUnderscores + , Test.test "Multiple underscores, one of them immediately before exponent 'e': '6_001_222_e+36' should fail at position 10" <| + \_ -> + expectErrAtPosition 10 SyntaxVersion.Guida "6_001_222_e+36" E.NumberNoUnderscoresAdjacentToDecimalOrExponent + , Test.test "One underscore immediately before exponent 'e': '222_e+36' should failt at position 4" <| + \_ -> + expectErrAtPosition 4 SyntaxVersion.Guida "222_e+36" E.NumberNoUnderscoresAdjacentToDecimalOrExponent + ] + , Test.describe "Float" + [ Test.test "No underscores 1000.42" <| + \_ -> + singleNumber SyntaxVersion.Guida "1000.42" + |> Expect.equal (Ok (N.Float 1000.42 "1000.42")) + , Test.test "Exponent and no underscores 6.022e23" <| + \_ -> + singleNumber SyntaxVersion.Guida "6.022e23" + |> Expect.equal (Ok (N.Float 6.022e23 "6.022e23")) + , Test.test "Exponent and +/- and no underscores 6000.022e+36" <| + \_ -> + singleNumber SyntaxVersion.Guida "6000.022e+36" + |> Expect.equal (Ok (N.Float 6.000022e39 "6000.022e+36")) + , Test.test "Underscore before decimal point 111_000.602" <| + \_ -> + singleNumber SyntaxVersion.Guida "111_000.602" + |> Expect.equal (Ok (N.Float 111000.602 "111_000.602")) + , Test.test "Underscore after decimal point 1000.4_205" <| + \_ -> + singleNumber SyntaxVersion.Guida "1000.4_205" + |> Expect.equal (Ok (N.Float 1000.4205 "1000.4_205")) + , Test.test "Underscore before and after decimal point 1_000.4_205" <| + \_ -> + singleNumber SyntaxVersion.Guida "1_000.4_205" + |> Expect.equal (Ok (N.Float 1000.4205 "1_000.4_205")) + , Test.test "Underscore before decimal point and exponent 60_000.022e3" <| + \_ -> + singleNumber SyntaxVersion.Guida "60_000.022e3" + |> Expect.equal (Ok (N.Float 60000022 "60_000.022e3")) + , Test.test "Underscore after exponent 6.022e2_3" <| + \_ -> + singleNumber SyntaxVersion.Guida "6.022e2_3" + |> Expect.equal (Ok (N.Float 6.022e23 "6.022e2_3")) + , Test.test "Underscores before and after decimal point and exponent and '+' 6_000.0_22e+3_6" <| + \_ -> + singleNumber SyntaxVersion.Guida "6_000.0_22e+3_6" + |> Expect.equal (Ok (N.Float 6.000022e39 "6_000.0_22e+3_6")) + , Test.test "Leading underscore: '_111000.602' should fail at position 1" <| + \_ -> + expectErrAtPosition 1 SyntaxVersion.Guida "_111000.602" E.NumberNoLeadingOrTrailingUnderscores + , Test.test "Trailing underscore: '111_000.602_' should fail at position 12" <| + \_ -> + expectErrAtPosition 12 SyntaxVersion.Guida "111_000.602_" E.NumberNoLeadingOrTrailingUnderscores + , Test.test "Consecutive underscore before decimal point: '111__000.602' should fail at position 5" <| + \_ -> + expectErrAtPosition 5 SyntaxVersion.Guida "111__000.602" E.NumberNoConsecutiveUnderscores + , Test.test "Consecutive underscore after decimal point: '111_000.6__002' should fail at position 11" <| + \_ -> + expectErrAtPosition 11 SyntaxVersion.Guida "111_000.6__002" E.NumberNoConsecutiveUnderscores + , Test.test "Underscore immediately after decimal point: '11._602' should fail at position 4" <| + \_ -> + expectErrAtPosition 4 SyntaxVersion.Guida "11._602" E.NumberNoUnderscoresAdjacentToDecimalOrExponent + , Test.test "Underscore immediately before decimal point: '11_.602' should fail at position 3" <| + \_ -> + expectErrAtPosition 3 SyntaxVersion.Guida "11_.602" E.NumberNoUnderscoresAdjacentToDecimalOrExponent + , Test.test "Underscore adjacent to +/- '6_000.022e+_36' should fail at position 12" <| + \_ -> + expectErrAtPosition 12 SyntaxVersion.Guida "6_000.022e+_36" E.NumberNoUnderscoresAdjacentToDecimalOrExponent + , Test.test "Underscore adjacent to +/- or immediately after exponent 'e': '6_000.022e_+36' should fail at position 11" <| + \_ -> + expectErrAtPosition 11 SyntaxVersion.Guida "6_000.022e_+36" E.NumberNoUnderscoresAdjacentToDecimalOrExponent + , Test.test "One underscore in fraction part immediately before exponent 'e': '6_000.022_e+36' should fail at position 10" <| + \_ -> + expectErrAtPosition 10 SyntaxVersion.Guida "6_000.022_e+36" E.NumberNoUnderscoresAdjacentToDecimalOrExponent + , Test.test "Multiple underscores in fraction part, one of them immediately before exponent 'e': '6_000.1_222_e+36' should fail at position 12" <| + \_ -> + expectErrAtPosition 12 SyntaxVersion.Guida "6_000.1_222_e+36" E.NumberNoUnderscoresAdjacentToDecimalOrExponent + ] + , Test.describe "Hexadecimal" + [ Test.test "No underscores 0xDEADBEEF" <| + \_ -> + singleNumber SyntaxVersion.Guida "0xDEADBEEF" + |> Expect.equal (Ok (N.Int 3735928559 "0xDEADBEEF")) + , Test.test "Underscores 0xDE_AD_BE_EF" <| + \_ -> + singleNumber SyntaxVersion.Guida "0xDE_AD_BE_EF" + |> Expect.equal (Ok (N.Int 3735928559 "0xDE_AD_BE_EF")) + , Test.test "Leading underscore: '_0xDEADBEEF' should fail at position 1" <| + \_ -> + expectErrAtPosition 1 SyntaxVersion.Guida "_0xDEADBEEF" E.NumberNoLeadingOrTrailingUnderscores + , Test.test "Trailing underscore: '0xDEADBEEF_' should fail at position 11" <| + \_ -> + expectErrAtPosition 11 SyntaxVersion.Guida "0xDEADBEEF_" E.NumberNoLeadingOrTrailingUnderscores + , Test.test "Consecutive underscores: '0xDE__ADBEEF' should fail at position 6" <| + \_ -> + expectErrAtPosition 6 SyntaxVersion.Guida "0xDE__ADBEEF" E.NumberNoConsecutiveUnderscores + , Test.test "Underscores adjacent to hexadecimal preFix '0x': '0x_DE_ADBEEF' should fail at position 3" <| + \_ -> + expectErrAtPosition 3 SyntaxVersion.Guida "0x_DE_ADBEEF" E.NumberNoUnderscoresAdjacentToHexadecimalPreFix + ] + , Test.describe "Binary" + [ Test.test "No underscores 0b1010" <| + \_ -> + singleNumber SyntaxVersion.Guida "0b1010" + |> Expect.equal (Ok (N.Int 10 "0b1010")) + , Test.test "Underscores 0xDE_AD_BE_EF" <| + \_ -> + singleNumber SyntaxVersion.Guida "0xDE_AD_BE_EF" + |> Expect.equal (Ok (N.Int 3735928559 "0xDE_AD_BE_EF")) + , Test.test "Leading underscore: '_0b1010' should fail at position 1" <| + \_ -> + expectErrAtPosition 1 SyntaxVersion.Guida "_0b1010" E.NumberNoLeadingOrTrailingUnderscores + , Test.test "Trailing underscore: '0b1010_' should fail at position 7" <| + \_ -> + expectErrAtPosition 7 SyntaxVersion.Guida "0b1010_" E.NumberNoLeadingOrTrailingUnderscores + , Test.test "Consecutive underscores: '0b10__10' should fail at position 6" <| + \_ -> + expectErrAtPosition 6 SyntaxVersion.Guida "0b10__10" E.NumberNoConsecutiveUnderscores + , Test.test "Underscores adjacent to binary preFix '0b': '0b_10_10' should fail at position 3" <| + \_ -> + expectErrAtPosition 3 SyntaxVersion.Guida "0b_10_10" E.NumberNoUnderscoresAdjacentToBinaryPreFix + ] + ] + , Test.describe "Elm" + [ Test.test "Int with no underscores 1000" <| + \_ -> + singleNumber SyntaxVersion.Elm "1000" + |> Expect.equal (Ok (N.Int 1000 "1000")) + , Test.test "Simple Float with no underscores 1000.42" <| + \_ -> + singleNumber SyntaxVersion.Elm "1000.42" + |> Expect.equal (Ok (N.Float 1000.42 "1000.42")) + , Test.test "Float with exponent and no underscores 6.022e23" <| + \_ -> + singleNumber SyntaxVersion.Elm "6.022e23" + |> Expect.equal (Ok (N.Float 6.022e23 "6.022e23")) + , Test.test "Float with exponent and +/- and no underscores 6000.022e+36" <| + \_ -> + singleNumber SyntaxVersion.Elm "6000.022e+36" + |> Expect.equal (Ok (N.Float 6.000022e39 "6000.022e+36")) + , Test.test "0xDEADBEEF" <| + \_ -> + singleNumber SyntaxVersion.Elm "0xDEADBEEF" + |> Expect.equal (Ok (N.Int 3735928559 "0xDEADBEEF")) + , Test.test "Int with one underscore 1_000" <| + \_ -> + singleNumber SyntaxVersion.Elm "1_000" + |> Expect.equal (Err E.NumberEnd) + , Test.test "Float with underscore before decimal point 111_000.602" <| + \_ -> + singleNumber SyntaxVersion.Elm "111_000.602" + |> Expect.equal (Err E.NumberEnd) + , Test.test "Float with underscore after decimal point 1000.4_205" <| + \_ -> + singleNumber SyntaxVersion.Elm "1000.4_205" + |> Expect.equal (Err E.NumberEnd) + , Test.test "Float with underscore before and after decimal point 1_000.4_205" <| + \_ -> + singleNumber SyntaxVersion.Elm "1_000.4_205" + |> Expect.equal (Err E.NumberEnd) + , Test.test "Float with underscore before decimal point and exponent 60_000.022e3" <| + \_ -> + singleNumber SyntaxVersion.Elm "60_000.022e3" + |> Expect.equal (Err E.NumberEnd) + , Test.test "Float with underscore after decimal point and exponent 6.022e2_3" <| + \_ -> + singleNumber SyntaxVersion.Elm "6.022e2_3" + |> Expect.equal (Err E.NumberEnd) + , Test.test "Float with underscores before and after decimal point and exponent and '+' 6_000.0_22e+3_6" <| + \_ -> + singleNumber SyntaxVersion.Elm "6_000.0_22e+3_6" + |> Expect.equal (Err E.NumberEnd) + , Test.test "0xDE_AD_BE_EF" <| + \_ -> + singleNumber SyntaxVersion.Elm "0xDE_AD_BE_EF" + |> Expect.equal (Err E.NumberHexDigit) + , Test.test "0b1010" <| + \_ -> + singleNumber SyntaxVersion.Elm "0b1010" + |> Expect.equal (Err E.NumberEnd) + ] + ] + + +singleNumber : SyntaxVersion -> String -> Result E.Number N.Number +singleNumber syntaxVersion = + P.fromByteString (N.number syntaxVersion (\_ _ -> E.NumberEnd) (\x _ _ -> x)) (\_ _ -> E.NumberEnd) + + +singleNumberAt : SyntaxVersion -> String -> Result ( E.Number, Int, Int ) N.Number +singleNumberAt syntaxVersion = + P.fromByteString + (N.number + syntaxVersion + (\row col -> ( E.NumberEnd, row, col )) + (\problem row col -> ( problem, row, col )) + ) + (\row col -> ( E.NumberEnd, row, col )) + + +expectErrAtPosition : + Int + -> SyntaxVersion + -> String + -> E.Number + -> Expect.Expectation +expectErrAtPosition col v src expected = + case singleNumberAt v src of + Err ( problem, _, c ) -> + Expect.all + [ \_ -> Expect.equal expected problem + , \_ -> Expect.equal col c + ] + () + + Ok value -> + Expect.fail ("Expected error " ++ Debug.toString expected ++ " but parsed " ++ Debug.toString value) diff --git a/tests/Parse/PrimitivesTests.elm b/tests/Parse/PrimitivesTests.elm new file mode 100644 index 0000000000..bee8bbbb35 --- /dev/null +++ b/tests/Parse/PrimitivesTests.elm @@ -0,0 +1,69 @@ +module Parse.PrimitivesTests exposing (suite) + +import Compiler.Parse.Primitives as P +import Expect +import Test exposing (Test) + + +suite : Test +suite = + Test.describe "Parse.Primitives" + [ Test.describe "getCharWidth" + [ Test.test "Latin Small Letter A" <| + \_ -> + P.getCharWidth 'a' + |> Expect.equal 1 + , Test.test "Latin Capital Letter Z" <| + \_ -> + P.getCharWidth 'Z' + |> Expect.equal 1 + , Test.test "Horizontal Ellipsis" <| + \_ -> + P.getCharWidth '…' + |> Expect.equal 1 + , Test.test "Black Right-Pointing Small Triangle" <| + \_ -> + P.getCharWidth '▸' + |> Expect.equal 1 + , Test.test "Black Down-Pointing Small Triangle" <| + \_ -> + P.getCharWidth '▾' + |> Expect.equal 1 + , Test.test "Black Down-Pointing Triangle" <| + \_ -> + P.getCharWidth '▼' + |> Expect.equal 1 + , Test.test "Heavy Black Heart" <| + \_ -> + P.getCharWidth '❤' + |> Expect.equal 1 + , Test.test "Full Block" <| + \_ -> + P.getCharWidth '█' + |> Expect.equal 1 + , Test.test "Light Shade" <| + \_ -> + P.getCharWidth '░' + |> Expect.equal 1 + , Test.test "Ballot X" <| + \_ -> + P.getCharWidth '✗' + |> Expect.equal 1 + , Test.test "Check Mark" <| + \_ -> + P.getCharWidth '✓' + |> Expect.equal 1 + , Test.test "Em Dash" <| + \_ -> + P.getCharWidth '—' + |> Expect.equal 1 + , Test.test "Rainbow" <| + \_ -> + P.getCharWidth '🌈' + |> Expect.equal 2 + , Test.test "Fire" <| + \_ -> + P.getCharWidth '🔥' + |> Expect.equal 2 + ] + ] diff --git a/tests/Parse/RecordTests.elm b/tests/Parse/RecordTests.elm new file mode 100644 index 0000000000..a2a4f864b2 --- /dev/null +++ b/tests/Parse/RecordTests.elm @@ -0,0 +1,181 @@ +module Parse.RecordTests exposing (suite) + +import Compiler.AST.Source as Src +import Compiler.Parse.Expression as E +import Compiler.Parse.Primitives as P +import Compiler.Parse.SyntaxVersion as SV exposing (SyntaxVersion) +import Compiler.Reporting.Annotation as A +import Compiler.Reporting.Error.Syntax as E +import Expect +import Test exposing (Test) + + +suite : Test +suite = + Test.describe "Parse.Record" + [ Test.describe "Elm" + [ Test.test "Empty record" <| + \_ -> + elmRecord "{}" + |> Expect.equal (Ok (A.at (A.Position 1 1) (A.Position 1 3) (Src.Record ( [], [] )))) + , Test.test "Extend record by unqualified name" <| + \_ -> + elmRecord "{ a | x = 2 }" + |> Expect.equal + (Ok + (A.at (A.Position 1 1) (A.Position 1 14) <| + Src.Update ( ( [], [] ), A.at (A.Position 1 3) (A.Position 1 4) (Src.Var Src.LowVar "a") ) + ( [] + , [ ( ( [], [], Nothing ) + , ( ( [], A.at (A.Position 1 7) (A.Position 1 8) "x" ) + , ( [], A.at (A.Position 1 11) (A.Position 1 12) (Src.Int 2 "2") ) + ) + ) + ] + ) + ) + ) + , Test.test "Extend record by qualified name" <| + \_ -> + elmRecord "{ A.b | x = 2 }" + |> Expect.equal (Err (E.Record (E.RecordOpen 1 3) 1 1)) + , Test.test "Extend record by nested qualified name" <| + \_ -> + elmRecord "{ A.B.c | x = 2 }" + |> Expect.equal (Err (E.Record (E.RecordOpen 1 3) 1 1)) + , Test.test "Extend record with custom type" <| + \_ -> + elmRecord "{ A | x = 2 }" + |> Expect.equal (Err (E.Record (E.RecordOpen 1 3) 1 1)) + , Test.test "Extend record with qualified custom type" <| + \_ -> + elmRecord "{ A.B | x = 2 }" + |> Expect.equal (Err (E.Record (E.RecordOpen 1 3) 1 1)) + ] + , Test.describe "Guida" + [ Test.test "Empty record" <| + \_ -> + guidaRecord "{}" + |> Expect.equal (Ok (A.at (A.Position 1 1) (A.Position 1 3) (Src.Record ( [], [] )))) + , Test.test "Extend record by unqualified name" <| + \_ -> + guidaRecord "{ a | x = 2 }" + |> Expect.equal + (Ok + (A.at (A.Position 1 1) (A.Position 1 14) <| + Src.Update ( ( [], [] ), A.at (A.Position 1 3) (A.Position 1 4) (Src.Var Src.LowVar "a") ) + ( [] + , [ ( ( [], [], Nothing ) + , ( ( [], A.at (A.Position 1 7) (A.Position 1 8) "x" ) + , ( [], A.at (A.Position 1 11) (A.Position 1 12) (Src.Int 2 "2") ) + ) + ) + ] + ) + ) + ) + , Test.test "Extend record by qualified name" <| + \_ -> + guidaRecord "{ A.b | x = 2 }" + |> Expect.equal + (Ok + (A.at (A.Position 1 1) (A.Position 1 16) <| + Src.Update ( ( [], [] ), A.at (A.Position 1 3) (A.Position 1 6) (Src.VarQual Src.LowVar "A" "b") ) + ( [] + , [ ( ( [], [], Nothing ) + , ( ( [], A.at (A.Position 1 9) (A.Position 1 10) "x" ) + , ( [], A.at (A.Position 1 13) (A.Position 1 14) (Src.Int 2 "2") ) + ) + ) + ] + ) + ) + ) + , Test.test "Extend record by nested qualified name" <| + \_ -> + guidaRecord "{ A.B.c | x = 2 }" + |> Expect.equal + (Ok + (A.at (A.Position 1 1) (A.Position 1 18) <| + Src.Update ( ( [], [] ), A.at (A.Position 1 3) (A.Position 1 8) (Src.VarQual Src.LowVar "A.B" "c") ) + ( [] + , [ ( ( [], [], Nothing ) + , ( ( [], A.at (A.Position 1 11) (A.Position 1 12) "x" ) + , ( [], A.at (A.Position 1 15) (A.Position 1 16) (Src.Int 2 "2") ) + ) + ) + ] + ) + ) + ) + , Test.test "Extend record by another record's field" <| + \_ -> + guidaRecord "{ a.b | x = 2 }" + |> Expect.equal + (Ok + (A.at (A.Position 1 1) (A.Position 1 16) <| + Src.Update + ( ( [], [] ) + , A.at (A.Position 1 3) (A.Position 1 6) <| + Src.Access (A.at (A.Position 1 3) (A.Position 1 4) (Src.Var Src.LowVar "a")) + (A.at (A.Position 1 5) (A.Position 1 6) "b") + ) + ( [] + , [ ( ( [], [], Nothing ) + , ( ( [], A.at (A.Position 1 9) (A.Position 1 10) "x" ) + , ( [], A.at (A.Position 1 13) (A.Position 1 14) (Src.Int 2 "2") ) + ) + ) + ] + ) + ) + ) + , Test.test "Extend record by nested qualified name and another record's field" <| + \_ -> + guidaRecord "{ A.B.c.d | x = 2 }" + |> Expect.equal + (Ok + (A.at (A.Position 1 1) (A.Position 1 20) <| + Src.Update + ( ( [], [] ) + , A.at (A.Position 1 3) + (A.Position 1 10) + (Src.Access (A.at (A.Position 1 3) (A.Position 1 8) (Src.VarQual Src.LowVar "A.B" "c")) + (A.at (A.Position 1 9) (A.Position 1 10) "d") + ) + ) + ( [] + , [ ( ( [], [], Nothing ) + , ( ( [], A.at (A.Position 1 13) (A.Position 1 14) "x" ) + , ( [], A.at (A.Position 1 17) (A.Position 1 18) (Src.Int 2 "2") ) + ) + ) + ] + ) + ) + ) + , Test.test "Extend record with custom type" <| + \_ -> + guidaRecord "{ A | x = 2 }" + |> Expect.equal (Err (E.Record (E.RecordOpen 1 3) 1 1)) + , Test.test "Extend record with qualified custom type" <| + \_ -> + guidaRecord "{ A.B | x = 2 }" + |> Expect.equal (Err (E.Record (E.RecordOpen 1 3) 1 1)) + ] + ] + + +elmRecord : String -> Result E.Expr Src.Expr +elmRecord = + record SV.Elm + + +guidaRecord : String -> Result E.Expr Src.Expr +guidaRecord = + record SV.Guida + + +record : SyntaxVersion -> String -> Result E.Expr Src.Expr +record syntaxVersion = + P.fromByteString (E.record syntaxVersion (A.Position 1 1)) E.Start diff --git a/tests/Parse/StringTests.elm b/tests/Parse/StringTests.elm new file mode 100644 index 0000000000..f69760df91 --- /dev/null +++ b/tests/Parse/StringTests.elm @@ -0,0 +1,36 @@ +module Parse.StringTests exposing (suite) + +import Compiler.Parse.Primitives as P +import Compiler.Parse.String as S +import Compiler.Parse.SyntaxVersion as SyntaxVersion +import Expect +import Test exposing (Test) + + +suite : Test +suite = + Test.describe "Parse.String" + [ Test.describe "singleString" + [ Test.test "🙈" <| + \_ -> + singleString "\"\\u{1F648}\"" + |> Expect.equal (Ok ( "\\uD83D\\uDE48", False )) + , Test.test "\\u{0001}" <| + \_ -> + singleString "\"\\u{0001}\"" + |> Expect.equal (Ok ( "\\u0001", False )) + , Test.test "\\u{FFFF}" <| + \_ -> + singleString "\"\\u{FFFF}\"" + |> Expect.equal (Ok ( "\\uD7FF\\uDFFF", False )) + , Test.test "\\u{10000}" <| + \_ -> + singleString "\"\\u{10000}\"" + |> Expect.equal (Ok ( "\\uD800\\uDC00", False )) + ] + ] + + +singleString : String -> Result () ( String, Bool ) +singleString = + P.fromByteString (S.string SyntaxVersion.Guida (\_ _ -> ()) (\_ _ _ -> ())) (\_ _ -> ()) diff --git a/tests/backwards-compatibility.test.js b/tests/backwards-compatibility.test.js new file mode 100644 index 0000000000..19af52f331 --- /dev/null +++ b/tests/backwards-compatibility.test.js @@ -0,0 +1,184 @@ +const fs = require("node:fs"); +const path = require("node:path"); +const childProcess = require("child_process"); +const os = require("os"); +const tmpDir = os.tmpdir(); + +const defaultFlags = ["no-flags", "debug", "optimize"]; + +const examples = [ + // HTML + ["Hello", defaultFlags], + ["Groceries", defaultFlags], + ["Shapes", defaultFlags], + // User Input + ["Buttons", defaultFlags], + ["TextFields", defaultFlags], + ["Forms", defaultFlags], + // Random + ["Numbers", defaultFlags], + ["Cards", defaultFlags], + ["Positions", defaultFlags], + // HTTP + ["Book", defaultFlags], + ["Quotes", defaultFlags], + // Time + ["CurrentTime", defaultFlags], + ["Clock", defaultFlags], + // Files + ["Upload", ["no-flags", "debug"]], + ["DragAndDrop", ["no-flags", "debug"]], + ["ImagePreviews", defaultFlags], + // WebGL + ["Triangle", defaultFlags], + ["Cube", defaultFlags], + ["Crate", defaultFlags], + ["Thwomp", defaultFlags], + ["FirstPerson", defaultFlags], + // Playground + ["Picture", defaultFlags], + ["Animation", defaultFlags], + ["Mouse", defaultFlags], + ["Keyboard", defaultFlags], + ["Turtle", defaultFlags], + ["Mario", defaultFlags], +]; + +const escapedNewCodeRegex = function (guidaOutput) { + return fs.readFileSync(guidaOutput).toString().replace("__END__\n", "__END__").replace(/\/\/__START__$(?:(?!__START__)[\s\S])*?\/\/__END__/gm, ""); +}; + +const generateCommandFlags = function (flag) { + if (flag === "no-flags") { + return ""; + } else { + return `--${flag}`; + } +}; + +describe("backwards compatibility", () => { + describe.each(examples)( + "produces the same code as elm for the %s example", + (example, currentFlags) => { + test.each(currentFlags)("%s", (flag) => { + const elmOutput = `${tmpDir}/guida-test-elm-${example}-${flag}-${process.pid}.js`; + const guidaOutput = `${tmpDir}/guida-test-guida-${example}-${flag}-${process.pid}.js`; + const commandFlag = generateCommandFlags(flag); + + try { + childProcess.execSync( + `elm make src/${example}.elm ${commandFlag} --output ${elmOutput}`, + { cwd: path.join(__dirname, "..", "examples") } + ); + } catch (e) { + console.error(e); + } + + try { + childProcess.execSync( + `../bin/index.js make src/${example}.elm ${commandFlag} --output ${guidaOutput}`, + { cwd: path.join(__dirname, "..", "examples") } + ); + } catch (e) { + console.error(e); + } + + expect(escapedNewCodeRegex(guidaOutput)).toBe(fs.readFileSync(elmOutput).toString()); + }); + } + ); + + test("self-hosted environment", () => { + const elmOutput = `${tmpDir}/guida-test-elm-self-hosted-${process.pid}.js`; + const guidaOutput = `${tmpDir}/guida-test-guida-self-hosted-${process.pid}.js`; + + try { + childProcess.execSync( + `elm make src/Terminal/Main.elm --output ${elmOutput}`, + { cwd: path.join(__dirname, "..") } + ); + } catch (e) { + console.error(e); + } + + try { + childProcess.execSync( + `./bin/index.js make src/Terminal/Main.elm --output ${guidaOutput}`, + { cwd: path.join(__dirname, "..") } + ); + } catch (e) { + console.error(e); + } + + expect(escapedNewCodeRegex(guidaOutput)).toBe(fs.readFileSync(elmOutput).toString()); + }); + + test("json report", () => { + const elmOutput = `${tmpDir}/guida-test-elm-json-report-${process.pid}.json`; + const guidaOutput = `${tmpDir}/guida-test-guida-json-report-${process.pid}.json`; + + try { + childProcess.execSync( + `elm make src/Invalid.elm --report=json &> ${elmOutput}`, + { cwd: path.join(__dirname, "..", "assets", "some-application") } + ); + } catch (_) { } + + try { + childProcess.execSync( + `../../bin/index.js make src/Invalid.elm --report=json &> ${guidaOutput}`, + { cwd: path.join(__dirname, "..", "assets", "some-application") } + ); + } catch (_) { } + + expect(fs.readFileSync(guidaOutput).toString()).toBe(fs.readFileSync(elmOutput).toString()); + }); + + test("docs", () => { + const elmOutput = `${tmpDir}/guida-test-elm-docs-${process.pid}.json`; + const guidaOutput = `${tmpDir}/guida-test-guida-docs-${process.pid}.json`; + + try { + childProcess.execSync( + `elm make --docs=${elmOutput}`, + { cwd: path.join(__dirname, "..", "assets", "some-package") } + ); + } catch (e) { + console.error(e); + } + + try { + childProcess.execSync( + `../../bin/index.js make --docs=${guidaOutput}`, + { cwd: path.join(__dirname, "..", "assets", "some-package") } + ); + } catch (e) { + console.error(e); + } + + expect(fs.readFileSync(guidaOutput).toString()).toBe(fs.readFileSync(elmOutput).toString()); + }); + + describe("tuples", () => { + test("fails on 3+ tuples on elm files", () => { + const elmOutput = `${tmpDir}/guida-test-elm-tuple-n-${process.pid}.json`; + const guidaOutput = `${tmpDir}/guida-test-guida-tuple-n-${process.pid}.json`; + + try { + childProcess.execSync( + `elm make src/ElmTupleN.elm --report=json &> ${elmOutput}`, + { cwd: path.join(__dirname, "..", "assets", "some-application") } + ); + } catch (_) { } + + try { + childProcess.execSync( + `../../bin/index.js make src/ElmTupleN.elm --report=json &> ${guidaOutput}`, + { cwd: path.join(__dirname, "..", "assets", "some-application") } + ); + } catch (_) { } + + expect(fs.readFileSync(guidaOutput).toString()).toBe(fs.readFileSync(elmOutput).toString()); + }); + }); +}); diff --git a/tests/format.test.js b/tests/format.test.js new file mode 100644 index 0000000000..c8e2e405ba --- /dev/null +++ b/tests/format.test.js @@ -0,0 +1,375 @@ +const fs = require("node:fs"); +const path = require("node:path"); +const childProcess = require("child_process"); +const os = require("os"); +const tmpDir = os.tmpdir(); + +const defaultModule = { + header: "module Main exposing (..)", + docs: "", + imports: [], + infixes: [], + declarations: ["fn = ()"] +} +const fullExample = { + ...defaultModule + , docs: `{-| Tons of useful functions that get imported by default. + +# Math +@docs Int, Float, (+), (-), (*), (/), (//), (^) + +# Int to Float / Float to Int +@docs toFloat, round, floor, ceiling, truncate + +# Equality +@docs (==), (/=) + +# Comparison + +These functions only work on \`comparable\` types. This includes numbers, +characters, strings, lists of comparable things, and tuples of comparable +things. + +@docs (<), (>), (<=), (>=), max, min, compare, Order + +# Booleans +@docs Bool, not, (&&), (||), xor + +# Append Strings and Lists +@docs (++) + +# Fancier Math +@docs modBy, remainderBy, negate, abs, clamp, sqrt, logBase, e + +# Angles +@docs degrees, radians, turns + +# Trigonometry +@docs pi, cos, sin, tan, acos, asin, atan, atan2 + +# Polar Coordinates +@docs toPolar, fromPolar + +# Floating Point Checks +@docs isNaN, isInfinite + +# Function Helpers +@docs identity, always, (<|), (|>), (<<), (>>), Never, never + +-}` + , imports: [ + "-- IMPORTS", + "import {- import1 -} Module1 -- first import comment", + "-- second import comment", + "import {- import2.1 -} Module2 {- import2.2 -} as {- import2.3 -} M {- import2.4 -}", + "import {- import3.1 -} Module3 {- import3.2 -} exposing {- import3.3 -} ({- import3.4 -} .. {- import3.5 -})", + "import {- import4.1 -} Module4 {- import4.2 -} exposing {- import4.3 -} ({- import4.4 -} fn1 {- import4.5 -}, {- import4.6 -} fn2 {- import4.7 -})", + `import -- import5.1 + Module5 -- import5.2 + exposing -- import5.3 + ( -- import5.4 + fn1 -- import5.5 + , -- import5.6 + fn2 -- import5.7 + )`, + "import {- import6.1 -} Module6 {- import6.2 -} as {- import6.3 -} M exposing {- import6.4 -} (..)", + ], infixes: [ + "-- INFIX OPERATORS", + "infix {- infix2 -} right {- infix3 -} 0 {- infix4 -} (<|) {- infix5 -} = {- infix6 -} apL", + "-- second infix comment", + `infix -- infix7 + left -- infix8 + 0 -- infix9 + (|>) -- infix10 + = -- infix11 + apR`, + ], declarations: [ + "-- DECLARATIONS", + "{-| port in comment -}", + "port {- port-in1 -} messageReceiver {- port-in2 -} : {- port-in3 -} ( {- port-in4 -} String {- port-in5 -} -> {- port-in6 -} msg {- port-in7 -}) {- port-in8 -} -> {- port-in9 -} Sub {- port-in10 -} msg {- port-in11 -}", + "{-| port out comment -}", + "port {- port-out1 -} sendMessage {- port-out2 -} : {- port-out3 -} String {- port-out4 -} -> {- port-out5 -} Cmd {- port-out6 -} msg {- port-out7 -}", + "{-| char comment -}", + "charFn {- char1 -} : {- char2 -} Char {- char3 -}", + "charFn {- char4 -} = {- char5 -} 'a' {- char6 -}", + "{-| string comment -}", + "stringFn {- string1 -} : {- string2 -} String {- string3 -}", + "stringFn {- string4 -} = {- string5 -} \"hello world!\" {- string6 -}", + "{-| multi-line string comment -}", + "stringMultiLineFn {- multi-line-string1 -} : {- multi-line-string2 -} String {- multi-line-string3 -}", + "stringMultiLineFn {- multi-line-string4 -} = {- multi-line-string5 -}\n \"\"\"\n This is useful for holding JSON or other\n content that has \"quotation marks\".\n \"\"\" {- multi-line-string6 -}", + "{-| int comment -}", + "intFn {- int1 -} : {- int2 -} Int {- int3 -}", + "intFn {- int4 -} = {- int5 -} 123 {- int6 -}", + "{-| float comment -}", + "floatFn {- float1 -} : {- float2 -} Float {- float3 -}", + "floatFn {- float4 -} = {- float5 -} 3.14 {- float6 -}", + "{-| lowVar comment -}", + "lowVarFn {- lowVar1 -} : {- lowVar2 -} a {- lowVar3 -} -> {- lowVar4 -} a {- lowVar5 -}", + "lowVarFn {- lowVar6 -} a {- lowVar7 -} = {- lowVar8 -} a {- lowVar9 -}", + "{-| capVar comment -}", + "capVarFn {- capVar1 -} : {- capVar2 -} Order {- capVar3 -}", + "capVarFn {- capVar4 -} = {- capVar5 -} EQ {- capVar6 -}", + "{-| lowVarQual comment -}", + "lowVarQualFn {- lowVarQual1 -} : {- lowVarQual2 -} Float {- lowVarQual3 -}", + "lowVarQualFn {- lowVarQual4 -} = {- lowVarQual5 -} Basics.e {- lowVarQual6 -}", + "{-| capVarQual comment -}", + "capVarQualFn {- capVarQual1 -} : {- capVarQual2 -} Basics.Order {- capVarQual3 -}", + "capVarQualFn {- capVarQual4 -} = {- capVarQual5 -} Basics.EQ {- capVarQual6 -}", + "{-| list comment -}", + "listFn {- list1 -} : {- list2 -} List {- list3 -} Int {- list4 -}", + "listFn {- list5 -} = {- list6 -} [ {- list7 -} 1 {- list8 -}, {- list9 -} 2 {- list10 -}, {- list11 -} 3 {- list12 -} ] {- list13 -}", + "{-| op comment -}", + "opFn {- op1 -} : {- op2 -} Int {- op3 -} -> {- op4 -} Int {- op5 -} -> {- op6 -} Int {- op7 -}", + "opFn {- op8 -} = {- op9 -} (+) {- op10 -}", + "{-| negate comment -}", + "negateFn {- negate1 -} : {- negate2 -} Int {- negate3 -}", + "negateFn {- negate4 -} = {- negate5 -} -4 {- negate6 -}", + "{-| binops comment -}", + "binopsFn {- binops1 -} : {- binops2 -} Int {- binops3 -}", + "binopsFn {- binops4 -} = {- binops5 -} 1 {- binops6 -} + {- binops7 -} 2 {- binops8 -}", + "{-| lambda arguments comment -}", + "lambdaArgFn {- lambdaArg1 -} : {- lambdaArg2 -} ( {- lambdaArg3 -} Int {- lambdaArg4 -} -> {- lambdaArg5 -} Bool {- lambdaArg6 -} ) {- lambdaArg7 -} -> List {- lambdaArg8 -} String {- lambdaArg9 -} -> {- lambdaArg10 -} Int {- lambdaArg11 -}", + "lambdaArgFn {- lambdaArg12 -} f {- lambdaArg13 -} = {- lambdaArg14 -} () {- lambdaArg15 -}", + "{-| call comments -}", + "callFn {- call1 -} : {- call2 -} Int {- call3 -}", + "callFn {- call4 -} = {- call5 -} negate {- call6 -} 1 {- call7 -}", + "{-| call multiple arguments comments -}", + "callMultiArgsFn {- callMultiArgs1 -} : {- callMultiArgs2 -} Int {- callMultiArgs3 -}", + "callMultiArgsFn {- callMultiArgs4 -} = {- callMultiArgs5 -} max {- callMultiArgs6 -} 1 {- callMultiArgs7 -} 2 {- callMultiArgs8 -}", + "{-| if comments -}", + "ifFn {- if1 -} : {- if2 -} Int {- if3 -}", + "ifFn {- if4 -} = {- if5 -} if {- if5 -} True {- if6 -} then {- if7 -} 1 {- if8 -} else {- if9 -} 2 {- if10 -}", + "{-| let comments -}", + "letFn {- let1 -} : {- let2 -} Int {- let3 -}", + "letFn {- let4 -} = {- let5 -} let {- let6 -} val {- let7 -} = {- let8 -} 42 {- let9 -} in {- let10 -} val {- let11 -}", + "{-| let multiple comments -}", + "letMultipleFn {- letMultiple1 -} : {- letMultiple2 -} Int {- letMultiple3 -}", + "letMultipleFn {- letMultiple4 -} = {- letMultiple5 -}\n let\n {- letMultiple6 -}\n val1 {- letMultiple7 -} = {- letMultiple8 -} 42 {- letMultiple9 -}\n {- letMultiple10 -}\n val2 {- letMultiple11 -} = {- letMultiple12 -} 43 {- letMultiple13 -}\n in {- letMultiple14 -} val {- letMultiple15 -}", + "{-| let destructure comments -}", + "letDestructureFn {- letDestructure1 -} : {- letDestructure2 -} Int {- letDestructure3 -}", + "letDestructureFn {- letDestructure4 -} = {- letDestructure5 -} let {- letDestructure6 -} { {- letDestructure7 -} val {- letDestructure8 -} } {- letDestructure9 -} = {- letDestructure10 -} someRecord {- letDestructure11 -} in {- letDestructure12 -} val {- letDestructure13 -}", + "{-| let signature and arguments comments -}", + "letSignatureArgsFn {- letSignatureArgs1 -} : {- letSignatureArgs2 -} Int {- letSignatureArgs3 -}", + "letSignatureArgsFn {- letSignatureArgs4 -} = {- letSignatureArgs5 -}\n let\n {- letSignatureArgs6 -}\n val1 {- letSignatureArgs7 -} : {- letSignatureArgs8 -} a {- letSignatureArgs9 -}\n val1 {- letSignatureArgs10 -} a {- letSignatureArgs11 -} = {- letSignatureArgs12 -} 42 {- letSignatureArgs13 -}\n in {- letSignatureArgs14 -} val {- letSignatureArgs15 -}", + "{-| case comments -}", + "caseFn {- case1 -} : {- case2 -} Int {- case3 -}", + `caseFn {- case4 -} = {- case5 -} case {- case6 -} () {- case7 -} of {- case8 -} + ({- case9 -} 1 {- case10 -}, {- case11 -} 2 {- case12 -}) -> {- case13 -} 3 {- case14 -} + [{- case15 -}] -> {- case16 -} 4 {- case17 -} + [{- case18 -} 1 {- case19 -}] -> {- case20 -} 5 {- case21 -} + [{- case22 -} 1 {- case23 -}, {- case24 -} 2 {- case25 -}] -> {- case26 -} 6 {- case27 -} + 1 {- case28 -} :: {- case29 -} 2 {- case30 -} :: {- case31 -} 3 {- case32 -} -> {- case33 -} 7 {- case34 -} + 1 {- case35 -} as {- case36 -} x {- case37 -} -> {- case38 -} 8 {- case39 -} + ({- case40 -} 1 {- case41 -} :: {- case42 -} [{- case43 -}] {- case44 -}) {- case45 -} as {- case46 -} y {- case47 -} -> {- case48 -} 9 {- case49 -} + (1) {- case50 -} as {- case51 -} z {- case52 -} -> {- case53 -} 10 {- case54 -} + _ {- case55 -} -> {- case56 -} 8 {- case57 -}`, + "{-| acces comments -}", + "accesFn {- acces1 -} : {- acces2 -} Int {- acces3 -}", + "accesFn {- acces4 -} = {- acces5 -} a.b {- acces6 -}", + "{-| update comments -}", + "updateFn {- update1 -} : {- update2 -} { {- update3 -} x {- update4 -} | {- update5 -} a {- update6 -} : {- update7 -} Int {- update8 -} , {- update9 -} b {- update10 -} : {- update11 -} Int {- update12 -} } {- update13 -}", + "updateFn {- update14 -} = {- update15 -} { {- update16 -} y {- update17 -} | {- update18 -} a {- update19 -} = {- update20 -} 1 {- update21 -} , {- update22 -} b {- update23 -} = {- update24 -} 2 {- update25 -} } {- update26 -}", + "{-| record comments -}", + "recordFn {- record1 -} : {- record2 -} { {- record3 -} a {- record4 -} : {- record5 -} Int {- record6 -} , {- record7 -} b {- record8 -} : {- record9 -} Int {- record10 -} } {- record11 -}", + "recordFn {- record12 -} = {- record13 -} { {- record14 -} a {- record15 -} = {- record16 -} 1 {- record17 -} , {- record18 -} b {- record19 -} = {- record20 -} 2 {- record21 -} } {- record22 -}", + "{-| empty record comments -}", + "emptyRecordFn {- emptyRecord1 -} : {- emptyRecord2 -} { {- emptyRecord3 -} } {- emptyRecord4 -}", + "emptyRecordFn {- emptyRecord5 -} = {- emptyRecord6 -} { {- emptyRecord7 -} } {- emptyRecord22 -}", + "{-| unit comment -}", + "unitFn {- unit1 -} : {- unit2 -} () {- unit3 -}", + "unitFn {- unit4 -} = {- unit5 -} () {- unit6 -}", + "{-| tuple comment -}", + "tupleFn {- tuple1 -} : {- tuple2 -} ( {- tuple3 -} Int {- tuple4 -}, {- tuple5 -} Int {- tuple6 -} ) {- tuple7 -}", + "tupleFn {- tuple8 -} = {- tuple9 -} ( {- tuple10 -} 1 {- tuple11 -}, {- tuple12 -} 2 {- tuple13 -} ) {- tuple14 -}", + "{-| shader comment -}", + "shaderFn {- shader1 -} : {- shader2 -} WebGL.Shader {- shader3 -} Vertex {- shader4 -} Uniforms {- shader5 -} { {- shader6 -} vcolor {- shader7 -} : {- shader8 -} Vec3 {- shader9 -} } {- shader10 -}", + "shaderFn {- shader11 -} = {- shader12 -} [glsl|\n attribute vec3 position;\n attribute vec3 color;\n uniform mat4 perspective;\n varying vec3 vcolor;\n\n void main () {\n gl_Position = perspective * vec4(position, 1.0);\n vcolor = color;\n }\n |] {- shader13 -}", + "{-| lambda comment -}", + "lambdaFn {- lambda1 -} : {- lambda2 -} Int {- lambda3 -} -> {- lambda4 -} () {- lambda5 -}", + "lambdaFn {- lambda6 -} = {- lambda7 -} \\_ {- lambda8 -} -> {- lambda9 -} () {- lambda10 -}", + "{-| trailing lambda comment -}", + "trailingLambdaFn {- trailingLambda1 -} : {- trailingLambda2 -} Int {- trailingLambda3 -} -> {- trailingLambda4 -} () {- trailingLambda5 -}", + "trailingLambdaFn {- trailingLambda6 -} = {- trailingLambda7 -} \\ {- trailingLambda8 -} a {- trailingLambda9 -} b {- trailingLambda10 -} -> {- trailingLambda11 -} () {- trailingLambda12 -}", + "{-| record case pattern comment -}", + "recordCasePatternFn {- recordCasePatternFn1 -} : {- recordCasePatternFn2 -} () {- recordCasePatternFn3 -}", + `recordCasePatternFn {- recordCasePatternFn4 -} = {- recordCasePatternFn5 -} case {- recordCasePatternFn6 -} () {- recordCasePatternFn7 -} of + {- recordCasePatternFn8 -} { {- recordCasePatternFn9 -} a {- recordCasePatternFn10 -}, {- recordCasePatternFn11 -} b {- recordCasePatternFn12 -} } {- recordCasePatternFn13 -} -> ()`, + "{-| union type with arguments comment -}", + "type {- UnionArgs1 -} UnionTypeArgs {- UnionArgs2 -} a {- UnionArgs3 -} b {- UnionArgs4 -} c {- UnionArgs5 -} = UnionTypeArgs1 {- UnionArgs6 -} a {- UnionArgs7 -} b {- UnionArgs8 -} c {- UnionArgs9 -} d {- UnionArgs10 -} | {- UnionArgs11 -} UnionTypeArgs2 {- UnionArgs12 -} a {- UnionArgs13 -} b {- UnionArgs14 -} c {- UnionArgs15 -} d {- UnionArgs16 -}", + "{-| parentheses comment -}", + "parenthesesFn {- parenthesesFn1 -} : {- parenthesesFn2 -} Int {- parenthesesFn3 -}", + "parenthesesFn {- parenthesesFn4 -} = {- parenthesesFn5 -} ({- parenthesesFn6 -} -1 {- parenthesesFn7 -}) {- parenthesesFn8 -} + {- parenthesesFn9 -} (-2 {- parenthesesFn10 -})", + ] +} + +const examples = [ + // HEADERS + ["Header", [ + { title: "no effects", filename: "NoEffects", module: defaultModule }, + { title: "ports", filename: "Ports", module: { ...defaultModule, header: "port module Main exposing (..)" } }, + { title: "manager", filename: "Manager", module: { ...defaultModule, header: "effect module Main where { command = MyCmd } exposing (..)" } }, + { title: "single-line exposing", filename: "SingleLineExposing", module: { ...defaultModule, header: "module Main exposing (fn1, fn2)" } }, + { title: "multi-line exposing", filename: "MultiLineExposing", module: { ...defaultModule, header: "module Main exposing (fn1\n , fn2)" } }, + { title: "all multi-line", filename: "AllMultiLineHeader", module: { ...defaultModule, header: "module\n Main\n exposing\n (fn1\n , fn2\n )" } }, + ]], + // DOCS + ["Docs", [ + { title: "basic", filename: "BasicDocs", module: { ...defaultModule, docs: "{-| some documentation\n-}" } }, + { title: "duplicate docs", filename: "ExposingDocs", module: { ...defaultModule, header: "module Main exposing (fn)", docs: "{-|\n@docs fn, fn\n-}", declarations: ["fn = ()"] } }, + ]], + // IMPORTS + ["Imports", [ + { title: "basic", filename: "BasicImports", module: { ...defaultModule, imports: ["import Module1"] } }, + { title: "alias", filename: "AliasImports", module: { ...defaultModule, imports: ["import Module1 as M"] } }, + { title: "exposing open", filename: "ExposingOpenImports", module: { ...defaultModule, imports: ["import Module1 exposing (..)"] } }, + { title: "exposing specific", filename: "ExposingSpecificImports", module: { ...defaultModule, imports: ["import Module1 exposing (fn1, fn2)"] } }, + { title: "all multi-line", filename: "AllMultiLineImports", module: { ...defaultModule, imports: ["import\n Module1\n exposing\n (fn1\n , fn2\n )"] } }, + ]], + // INFIXES + ["Infixes", [ + { + title: "basic", filename: "BasicInfixes", module: { + ...defaultModule, infixes: [ + "infix right 0 (<|) = apL", + "infix left 0 (|>) = apR", + "infix right 2 (||) = or", + "infix non 4 (<) = lt", + "infix non 4 (>) = gt", + "infix non 4 (<=) = le" + ] + } + }, + ]], + // VALUE DECLARATIONS + ["Declarations", [ + { title: "unit type", filename: "UnitTypeDeclarations", module: { ...defaultModule, declarations: ["fn : ()\nfn = ()"] } }, + { title: "tuple type", filename: "TupleTypeDeclarations", module: { ...defaultModule, declarations: ["fn : ((), ())\nfn = ((), ())"] } }, + { title: "var type", filename: "VarTypeDeclarations", module: { ...defaultModule, declarations: ["fn : a -> a\nfn a = a"] } }, + { title: "unqualified type", filename: "UnqualifiedTypeDeclarations", module: { ...defaultModule, declarations: ["fn : List a -> List a\nfn list = list"] } }, + { title: "qualified type", filename: "QualifiedTypeDeclarations", module: { ...defaultModule, declarations: ["fn : Dict.Dict a -> Dict.Dict a\nfn dict = dict"] } }, + { title: "argument w/ parentheses type", filename: "ArgumentWithParenthesesTypeDeclarations", module: { ...defaultModule, declarations: ["fn : List (Maybe a)\nfn = []"] } }, + { title: "multiple declarations", filename: "MultipleDeclarations", module: { ...defaultModule, declarations: ["fn1 = ()\nfn2 = ()"] } }, + { title: "let block", filename: "LetBlockDeclarations", module: { ...defaultModule, declarations: ["fn = let _ = () in ()"] } }, + { title: "anonymous function", filename: "AnonymousFunctionDeclarations", module: { ...defaultModule, declarations: ["fn = \\_ -> ()"] } }, + { title: "anonymous function argument", filename: "AnonymousFunctionArgDeclarations", module: { ...defaultModule, declarations: ["fn = List.map (\\_ -> ())"] } }, + { title: "pipe operator", filename: "PipeOperatorDeclarations", module: { ...defaultModule, declarations: ["fn = \"\"\n |> String.trim"] } }, + { title: "list", filename: "ListDeclarations", module: { ...defaultModule, declarations: ["fn = [1,2,3]"] } }, + { title: "multi-line list", filename: "MultiLineListDeclarations", module: { ...defaultModule, declarations: ["fn = [\n 1,\n 2,3]"] } }, + { title: "multi-line signature", filename: "MultiLineSignatureDeclarations", module: { ...defaultModule, declarations: ["fn : a\n -> a", "fn = ()"] } }, + { title: "multi-line type signature", filename: "MultiLineTypeSignatureDeclarations", module: { ...defaultModule, declarations: ["fn : List\n a", "fn = ()"] } }, + { title: "multi-line qualified type signature", filename: "MultiLineQualifiedTypeSignatureDeclarations", module: { ...defaultModule, declarations: ["fn : Map.Dict\n k\n v", "fn = ()"] } }, + { title: "multi-line tuple signature", filename: "MultiLineTupleSignatureDeclarations", module: { ...defaultModule, declarations: ["fn : (a\n , b)", "fn = ()"] } }, + { title: "remove unnecessary parentheses", filename: "RemoveUnnecessaryParenthesesDeclarations", module: { ...defaultModule, declarations: ["fn = ((add) 1) 2"] } }, + { title: "argument w/ parentheses", filename: "ArgumentWithParenthesesDeclarations", module: { ...defaultModule, declarations: ["fn input = String.toInt (String.trim input)"] } }, + { + title: "literals", filename: "LiteralDeclarations", module: { + ...defaultModule, declarations: [ + "decimalInt = 123", + "hexadecimalInt = 0xff", + "decimalFloat = 3.14", + "exponentFloat = 6.022e23", + // TODO "smallExponentFloat = 1e3", + `chars = ['a', '\\n', '\\t', '\t', '\\\\', '\\"', '\\'', '\u{2028}', '\u{2029}', 'ͷ']`, + `singleQuotedString = "hello world! Characters: \\n \\t \t \\\\ \\" \\' ' \u{2028} \u{2029} ͷ"`, + `tripleQuotedString = """multiline\nstrings\nwith 'single quotes' and \\"double quotes\\"\nCharacters: \\n \\t \t \\\\ \\" \\' ' \u{2028} \u{2029} ͷ"""`, + ] + } + }, + { title: "multi-line record", filename: "MultiLineRecordDeclarations", module: { ...defaultModule, declarations: [`recordFn =\n { age = 23\n , name =\n "John"\n }`] } }, + { title: "multi-line update record", filename: "MultiLineUpdateRecordDeclarations", module: { ...defaultModule, declarations: [`updateRecordFn =\n { record | age = 23\n , name = "John"\n }`] } }, + ]], + // UNION DECLARATIONS + ["Union", [ + { title: "single variant", filename: "SingleTypeUnionDeclarations", module: { ...defaultModule, declarations: ["type A = A"] } }, + { title: "keep original order", filename: "KeepOriginalOrderUnionDeclarations", module: { ...defaultModule, declarations: ["type A = A | B | C"] } }, + ]], + // ALIAS DECLARATIONS + ["Alias", [ + { title: "integer", filename: "IntergerAliasDeclarations", module: { ...defaultModule, declarations: ["type alias A = Int"] } }, + { title: "single field record", filename: "SingleFieldRecordAliasDeclarations", module: { ...defaultModule, declarations: ["type alias A = { age: Int }"] } }, + { title: "multi-line record", filename: "MultiLineRecordAliasDeclarations", module: { ...defaultModule, declarations: ["type alias A = { age: Int\n , name: String }"] } }, + ]], + // PORT DECLARATIONS + ["Port", [ + { title: "in", filename: "InPortDeclarations", module: { ...defaultModule, declarations: ["port messageReceiver : (String -> msg) -> Sub msg"] } }, + { title: "out", filename: "OutPortDeclarations", module: { ...defaultModule, declarations: ["port sendMessage : String -> Cmd msg"] } }, + ]], + // COMMENTS + ["Comments", [ + { title: "single-line before header", filename: "SingleLineBeforeHeaderComments", module: { ...defaultModule, header: ["-- COMMENT\nmodule Main exposing (..)"] } }, + { title: "multi-line header", filename: "MultiLineHeaderComments", module: { ...defaultModule, header: ["module {- C1 -} Main {- C2 -} exposing {- C3 -} ({- C4 -}..{- C5 -})"] } }, + { title: "single-line header", filename: "SingleLineHeaderComments", module: { ...defaultModule, header: ["module -- C1\n Main -- C2\n exposing -- C3\n (..)"] } }, + { title: "port header", filename: "PortHeaderComments", module: { ...defaultModule, header: ["{- C1 -}\nport {- C2 -} module {- C3 -} Main {- C4 -} exposing {- C5 -} (..)"] } }, + { title: "manager header", filename: "ManagerHeaderComments", module: { ...defaultModule, header: ["{- C1 -}\neffect {- C2 -} module {- C3 -} Main {- C4 -} where {- C5 -} { {- C6 -} command {- C7 -} = {- C8 -} MyCmd {- C9 -} , {- C10 -} subscription {- C11 -} = {- C12 -} MySub {- C13 -} } {- C14 -} exposing {- C15 -} (..)"] } }, + { title: "header exposed", filename: "HeaderExposedComments", module: { ...defaultModule, header: ["module Main exposing ({- C1 -} A {- C2 -} ({- C3 -}..{- C4 -}), {- C5 -} B {- C6 -} ({- C7 -}..{- C8 -}), {- C9 -} C {- C10 -}, {- C11 -} fn {- C12 -})"] } }, + { title: "single-line declaration", filename: "SingleLineDeclarationComments", module: { ...defaultModule, declarations: ["-- COMMENT", "fn = ()"] } }, + { title: "infix", filename: "InfixComments", module: { ...defaultModule, infixes: ["infix {- 1 -} right {- 2 -} 0 {- 3 -} (<|) {- 4 -} = {- 5 -} apL"] } }, + { + title: "top-level after lambda", filename: "TopLevelAfterLambdaComments", module: { + ...defaultModule, declarations: [ + "lambdaFn = \\_ -> ()", + "-- COMMENT", + "anotherFn = 2" + ] + } + }, + { + title: "top-level after nested lambda", filename: "TopLevelAfterNestedLambdaComments", module: { + ...defaultModule, declarations: [ + "pipeFn = fn <| \\_ -> ()", + "-- COMMENT", + "anotherFn = 2" + ] + } + }, + { + title: "top-level after union type", filename: "TopLevelAfterUnionTypeComments", module: { + ...defaultModule, declarations: [ + "type A = A", + "-- COMMENT", + "fn = 1" + ] + } + }, + { + title: "trailing top-level", filename: "TrailingTopLevelComments", module: { + ...defaultModule, declarations: [ + "fn = 1", + "-- COMMENT", + ] + } + }, + { title: "full-example", filename: "FullExample", module: fullExample } + ]], +] + +describe("format", () => { + describe.each(examples)("%s", (example, modules) => { + test.each(modules)("$title", ({ filename, module }) => { + const moduleFilename = `${tmpDir}/GuidaTest${example}${filename}${process.pid}.Elm`; + const elmOutput = `${tmpDir}/GuidaTestElmOutput${example}${filename}${process.pid}.Elm`; + const guidaOutput = `${tmpDir}/GuidaTestGuidaOutput${example}${filename}${process.pid}.Elm`; + + fs.writeFileSync(moduleFilename, generateModule(module)); + + childProcess.execSync(`elm-format ${moduleFilename} --output ${elmOutput}`, { + cwd: path.join(__dirname, "..") + }); + + childProcess.execSync(`./bin/index.js format ${moduleFilename} --output ${guidaOutput}`, { + cwd: path.join(__dirname, "..") + }); + + expect(fs.readFileSync(guidaOutput).toString()).toBe(fs.readFileSync(elmOutput).toString()); + }); + }); +}); + +const generateModule = ({ header, docs, imports, infixes, declarations }) => { + return `${header} +${docs} +${imports.join("\n")} +${infixes.join("\n")} +${declarations.join("\n")}`; +} \ No newline at end of file diff --git a/tests/maybe-map.test.js b/tests/maybe-map.test.js new file mode 100644 index 0000000000..a592bebfef --- /dev/null +++ b/tests/maybe-map.test.js @@ -0,0 +1,16 @@ +const path = require("path"); +const childProcess = require("child_process"); + +describe("maybe map", () => { + test("performance for large mapping sequence", () => { + const start = Date.now(); + + childProcess.execSync( + `../../bin/index.js make src/MaybeMap.elm`, + { cwd: path.join(__dirname, "..", "assets", "some-application") } + ); + + const duration = Date.now() - start; + expect(duration).toBeLessThan(10_000); + }); +}); \ No newline at end of file diff --git a/tests/repl.test.js b/tests/repl.test.js new file mode 100644 index 0000000000..a9004afe88 --- /dev/null +++ b/tests/repl.test.js @@ -0,0 +1,28 @@ +const child_process = require("node:child_process"); +const path = require("node:path"); + +describe("repl", () => { + test("1 + 1", (done) => { + run("1 + 1", "\x1B[95m2\x1B[0m\x1B[90m : number\x1B[0m\n", done); + }, 120_000); + + test("string", (done) => { + run("\"Hello, World!\"", "\x1B[93m\"Hello, World!\"\x1B[0m\x1B[90m : String\x1B[0m\n", done); + }, 120_000); +}); + +const run = (input, output, done) => { + const repl = child_process.spawn("./bin/index.js", ["repl"], { + cwd: path.join(__dirname, ".."), + stdio: "pipe" + }); + + repl.stdout.on("data", (data) => { + if (data.toString() === "> ") { + repl.stdin.write(input + "\n"); + } else if (data.toString() === output) { + repl.kill(); + done(); + } + }); +} \ No newline at end of file diff --git a/tests/tuples.test.js b/tests/tuples.test.js new file mode 100644 index 0000000000..7eb9cea484 --- /dev/null +++ b/tests/tuples.test.js @@ -0,0 +1,13 @@ +const path = require("path"); +const childProcess = require("child_process"); + +describe("tuples", () => { + test("allows 3+ tuples", () => { + expect(() => { + childProcess.execSync( + `../../bin/index.js make src/GuidaTupleN.guida`, + { cwd: path.join(__dirname, "..", "assets", "some-application") } + ); + }).not.toThrow(); + }); +}); \ No newline at end of file diff --git a/try/README.md b/try/README.md new file mode 100644 index 0000000000..ac24e12af3 --- /dev/null +++ b/try/README.md @@ -0,0 +1,25 @@ +# Guida Try + +This is an example of how to use the browser version of the compiler. + +## How to run + +To run this example, follow these steps: + +1. Start by building guida for the browser at the top level folder by running the following: + +``` +nvm use +npm install +npm run build:browser +``` + +2. Move into this folder and install the dependecies: + +``` +cd try +npm install +``` + +3. Start the server with `npm run server` +4. Open http://127.0.0.1:8088 \ No newline at end of file diff --git a/try/app.js b/try/app.js new file mode 100644 index 0000000000..49beab504f --- /dev/null +++ b/try/app.js @@ -0,0 +1,58 @@ +const guida = require("guida"); + +window.addEventListener("load", async () => { + const app = await guida.init({ GUIDA_REGISTRY: "/proxy/https://package.elm-lang.org" }); + + const code = document.getElementById("code"); + + const mode = document.getElementById("mode"); + const sourcemaps = document.getElementById("sourcemaps-input"); + const format = document.getElementById("format"); + const run = document.getElementById("run"); + + const dependency = document.getElementById("dependency"); + const install = document.getElementById("install"); + const uninstall = document.getElementById("uninstall"); + + const preview = document.getElementById("preview"); + + format.addEventListener("click", async () => { + const result = await app.format(code.value); + + if (Object.prototype.hasOwnProperty.call(result, "error")) { + console.error(JSON.parse(result.error)); + } else { + code.value = result.output; + } + }); + + run.addEventListener("click", async () => { + const result = await app.make(code.value, { + debug: mode.value === "debug", + optimize: mode.value === "prod", + sourcemaps: sourcemaps.checked + }); + + if (Object.prototype.hasOwnProperty.call(result, "error")) { + console.error(result.error); + } else { + preview.srcdoc = result.output; + } + }); + + install.addEventListener("click", async () => { + const result = await app.install(dependency.value); + + if (result && Object.prototype.hasOwnProperty.call(result, "error")) { + console.error(result.error); + } + }); + + uninstall.addEventListener("click", async () => { + const result = await app.uninstall(dependency.value); + + if (result && Object.prototype.hasOwnProperty.call(result, "error")) { + console.error(result.error); + } + }); +}); \ No newline at end of file diff --git a/try/package-lock.json b/try/package-lock.json new file mode 100644 index 0000000000..6316c22cb0 --- /dev/null +++ b/try/package-lock.json @@ -0,0 +1,1539 @@ +{ + "name": "guida-try", + "version": "1.0.0", + "lockfileVersion": 3, + "requires": true, + "packages": { + "": { + "name": "guida-try", + "version": "1.0.0", + "dependencies": { + "cors": "^2.8.5", + "esbuild": "^0.25.1", + "express": "^4.21.2", + "guida": "file:..", + "http-proxy-middleware": "^3.0.3" + } + }, + "..": { + "name": "guida", + "version": "1.0.0", + "license": "BSD-3-Clause", + "dependencies": { + "adm-zip": "^0.5.16", + "form-data": "^4.0.2", + "indexeddb-fs": "^2.1.5", + "jszip": "^3.10.1", + "mock-xmlhttprequest": "^8.4.1", + "tmp": "^0.2.3", + "which": "^5.0.0" + }, + "bin": { + "guida": "bin/index.js" + }, + "devDependencies": { + "elm": "^0.19.1-6", + "elm-format": "^0.8.7", + "elm-review": "^2.13.2", + "elm-test": "^0.19.1-revision15", + "guida": "^0.3.0-alpha", + "jest": "^29.7.0", + "npm-run-all": "^4.1.5", + "uglify-js": "^3.19.3" + } + }, + "node_modules/@esbuild/aix-ppc64": { + "version": "0.25.1", + "resolved": "https://registry.npmjs.org/@esbuild/aix-ppc64/-/aix-ppc64-0.25.1.tgz", + "integrity": "sha512-kfYGy8IdzTGy+z0vFGvExZtxkFlA4zAxgKEahG9KE1ScBjpQnFsNOX8KTU5ojNru5ed5CVoJYXFtoxaq5nFbjQ==", + "cpu": [ + "ppc64" + ], + "license": "MIT", + "optional": true, + "os": [ + "aix" + ], + "engines": { + "node": ">=18" + } + }, + "node_modules/@esbuild/android-arm": { + "version": "0.25.1", + "resolved": "https://registry.npmjs.org/@esbuild/android-arm/-/android-arm-0.25.1.tgz", + "integrity": "sha512-dp+MshLYux6j/JjdqVLnMglQlFu+MuVeNrmT5nk6q07wNhCdSnB7QZj+7G8VMUGh1q+vj2Bq8kRsuyA00I/k+Q==", + "cpu": [ + "arm" + ], + "license": "MIT", + "optional": true, + "os": [ + "android" + ], + "engines": { + "node": ">=18" + } + }, + "node_modules/@esbuild/android-arm64": { + "version": "0.25.1", + "resolved": "https://registry.npmjs.org/@esbuild/android-arm64/-/android-arm64-0.25.1.tgz", + "integrity": "sha512-50tM0zCJW5kGqgG7fQ7IHvQOcAn9TKiVRuQ/lN0xR+T2lzEFvAi1ZcS8DiksFcEpf1t/GYOeOfCAgDHFpkiSmA==", + "cpu": [ + "arm64" + ], + "license": "MIT", + "optional": true, + "os": [ + "android" + ], + "engines": { + "node": ">=18" + } + }, + "node_modules/@esbuild/android-x64": { + "version": "0.25.1", + "resolved": "https://registry.npmjs.org/@esbuild/android-x64/-/android-x64-0.25.1.tgz", + "integrity": "sha512-GCj6WfUtNldqUzYkN/ITtlhwQqGWu9S45vUXs7EIYf+7rCiiqH9bCloatO9VhxsL0Pji+PF4Lz2XXCES+Q8hDw==", + "cpu": [ + "x64" + ], + "license": "MIT", + "optional": true, + "os": [ + "android" + ], + "engines": { + "node": ">=18" + } + }, + "node_modules/@esbuild/darwin-arm64": { + "version": "0.25.1", + "resolved": "https://registry.npmjs.org/@esbuild/darwin-arm64/-/darwin-arm64-0.25.1.tgz", + "integrity": "sha512-5hEZKPf+nQjYoSr/elb62U19/l1mZDdqidGfmFutVUjjUZrOazAtwK+Kr+3y0C/oeJfLlxo9fXb1w7L+P7E4FQ==", + "cpu": [ + "arm64" + ], + "license": "MIT", + "optional": true, + "os": [ + "darwin" + ], + "engines": { + "node": ">=18" + } + }, + "node_modules/@esbuild/darwin-x64": { + "version": "0.25.1", + "resolved": "https://registry.npmjs.org/@esbuild/darwin-x64/-/darwin-x64-0.25.1.tgz", + "integrity": "sha512-hxVnwL2Dqs3fM1IWq8Iezh0cX7ZGdVhbTfnOy5uURtao5OIVCEyj9xIzemDi7sRvKsuSdtCAhMKarxqtlyVyfA==", + "cpu": [ + "x64" + ], + "license": "MIT", + "optional": true, + "os": [ + "darwin" + ], + "engines": { + "node": ">=18" + } + }, + "node_modules/@esbuild/freebsd-arm64": { + "version": "0.25.1", + "resolved": "https://registry.npmjs.org/@esbuild/freebsd-arm64/-/freebsd-arm64-0.25.1.tgz", + "integrity": "sha512-1MrCZs0fZa2g8E+FUo2ipw6jw5qqQiH+tERoS5fAfKnRx6NXH31tXBKI3VpmLijLH6yriMZsxJtaXUyFt/8Y4A==", + "cpu": [ + "arm64" + ], + "license": "MIT", + "optional": true, + "os": [ + "freebsd" + ], + "engines": { + "node": ">=18" + } + }, + "node_modules/@esbuild/freebsd-x64": { + "version": "0.25.1", + "resolved": "https://registry.npmjs.org/@esbuild/freebsd-x64/-/freebsd-x64-0.25.1.tgz", + "integrity": "sha512-0IZWLiTyz7nm0xuIs0q1Y3QWJC52R8aSXxe40VUxm6BB1RNmkODtW6LHvWRrGiICulcX7ZvyH6h5fqdLu4gkww==", + "cpu": [ + "x64" + ], + "license": "MIT", + "optional": true, + "os": [ + "freebsd" + ], + "engines": { + "node": ">=18" + } + }, + "node_modules/@esbuild/linux-arm": { + "version": "0.25.1", + "resolved": "https://registry.npmjs.org/@esbuild/linux-arm/-/linux-arm-0.25.1.tgz", + "integrity": "sha512-NdKOhS4u7JhDKw9G3cY6sWqFcnLITn6SqivVArbzIaf3cemShqfLGHYMx8Xlm/lBit3/5d7kXvriTUGa5YViuQ==", + "cpu": [ + "arm" + ], + "license": "MIT", + "optional": true, + "os": [ + "linux" + ], + "engines": { + "node": ">=18" + } + }, + "node_modules/@esbuild/linux-arm64": { + "version": "0.25.1", + "resolved": "https://registry.npmjs.org/@esbuild/linux-arm64/-/linux-arm64-0.25.1.tgz", + "integrity": "sha512-jaN3dHi0/DDPelk0nLcXRm1q7DNJpjXy7yWaWvbfkPvI+7XNSc/lDOnCLN7gzsyzgu6qSAmgSvP9oXAhP973uQ==", + "cpu": [ + "arm64" + ], + "license": "MIT", + "optional": true, + "os": [ + "linux" + ], + "engines": { + "node": ">=18" + } + }, + "node_modules/@esbuild/linux-ia32": { + "version": "0.25.1", + "resolved": "https://registry.npmjs.org/@esbuild/linux-ia32/-/linux-ia32-0.25.1.tgz", + "integrity": "sha512-OJykPaF4v8JidKNGz8c/q1lBO44sQNUQtq1KktJXdBLn1hPod5rE/Hko5ugKKZd+D2+o1a9MFGUEIUwO2YfgkQ==", + "cpu": [ + "ia32" + ], + "license": "MIT", + "optional": true, + "os": [ + "linux" + ], + "engines": { + "node": ">=18" + } + }, + "node_modules/@esbuild/linux-loong64": { + "version": "0.25.1", + "resolved": "https://registry.npmjs.org/@esbuild/linux-loong64/-/linux-loong64-0.25.1.tgz", + "integrity": "sha512-nGfornQj4dzcq5Vp835oM/o21UMlXzn79KobKlcs3Wz9smwiifknLy4xDCLUU0BWp7b/houtdrgUz7nOGnfIYg==", + "cpu": [ + "loong64" + ], + "license": "MIT", + "optional": true, + "os": [ + "linux" + ], + "engines": { + "node": ">=18" + } + }, + "node_modules/@esbuild/linux-mips64el": { + "version": "0.25.1", + "resolved": "https://registry.npmjs.org/@esbuild/linux-mips64el/-/linux-mips64el-0.25.1.tgz", + "integrity": "sha512-1osBbPEFYwIE5IVB/0g2X6i1qInZa1aIoj1TdL4AaAb55xIIgbg8Doq6a5BzYWgr+tEcDzYH67XVnTmUzL+nXg==", + "cpu": [ + "mips64el" + ], + "license": "MIT", + "optional": true, + "os": [ + "linux" + ], + "engines": { + "node": ">=18" + } + }, + "node_modules/@esbuild/linux-ppc64": { + "version": "0.25.1", + "resolved": "https://registry.npmjs.org/@esbuild/linux-ppc64/-/linux-ppc64-0.25.1.tgz", + "integrity": "sha512-/6VBJOwUf3TdTvJZ82qF3tbLuWsscd7/1w+D9LH0W/SqUgM5/JJD0lrJ1fVIfZsqB6RFmLCe0Xz3fmZc3WtyVg==", + "cpu": [ + "ppc64" + ], + "license": "MIT", + "optional": true, + "os": [ + "linux" + ], + "engines": { + "node": ">=18" + } + }, + "node_modules/@esbuild/linux-riscv64": { + "version": "0.25.1", + "resolved": "https://registry.npmjs.org/@esbuild/linux-riscv64/-/linux-riscv64-0.25.1.tgz", + "integrity": "sha512-nSut/Mx5gnilhcq2yIMLMe3Wl4FK5wx/o0QuuCLMtmJn+WeWYoEGDN1ipcN72g1WHsnIbxGXd4i/MF0gTcuAjQ==", + "cpu": [ + "riscv64" + ], + "license": "MIT", + "optional": true, + "os": [ + "linux" + ], + "engines": { + "node": ">=18" + } + }, + "node_modules/@esbuild/linux-s390x": { + "version": "0.25.1", + "resolved": "https://registry.npmjs.org/@esbuild/linux-s390x/-/linux-s390x-0.25.1.tgz", + "integrity": "sha512-cEECeLlJNfT8kZHqLarDBQso9a27o2Zd2AQ8USAEoGtejOrCYHNtKP8XQhMDJMtthdF4GBmjR2au3x1udADQQQ==", + "cpu": [ + "s390x" + ], + "license": "MIT", + "optional": true, + "os": [ + "linux" + ], + "engines": { + "node": ">=18" + } + }, + "node_modules/@esbuild/linux-x64": { + "version": "0.25.1", + "resolved": "https://registry.npmjs.org/@esbuild/linux-x64/-/linux-x64-0.25.1.tgz", + "integrity": "sha512-xbfUhu/gnvSEg+EGovRc+kjBAkrvtk38RlerAzQxvMzlB4fXpCFCeUAYzJvrnhFtdeyVCDANSjJvOvGYoeKzFA==", + "cpu": [ + "x64" + ], + "license": "MIT", + "optional": true, + "os": [ + "linux" + ], + "engines": { + "node": ">=18" + } + }, + "node_modules/@esbuild/netbsd-arm64": { + "version": "0.25.1", + "resolved": "https://registry.npmjs.org/@esbuild/netbsd-arm64/-/netbsd-arm64-0.25.1.tgz", + "integrity": "sha512-O96poM2XGhLtpTh+s4+nP7YCCAfb4tJNRVZHfIE7dgmax+yMP2WgMd2OecBuaATHKTHsLWHQeuaxMRnCsH8+5g==", + "cpu": [ + "arm64" + ], + "license": "MIT", + "optional": true, + "os": [ + "netbsd" + ], + "engines": { + "node": ">=18" + } + }, + "node_modules/@esbuild/netbsd-x64": { + "version": "0.25.1", + "resolved": "https://registry.npmjs.org/@esbuild/netbsd-x64/-/netbsd-x64-0.25.1.tgz", + "integrity": "sha512-X53z6uXip6KFXBQ+Krbx25XHV/NCbzryM6ehOAeAil7X7oa4XIq+394PWGnwaSQ2WRA0KI6PUO6hTO5zeF5ijA==", + "cpu": [ + "x64" + ], + "license": "MIT", + "optional": true, + "os": [ + "netbsd" + ], + "engines": { + "node": ">=18" + } + }, + "node_modules/@esbuild/openbsd-arm64": { + "version": "0.25.1", + "resolved": "https://registry.npmjs.org/@esbuild/openbsd-arm64/-/openbsd-arm64-0.25.1.tgz", + "integrity": "sha512-Na9T3szbXezdzM/Kfs3GcRQNjHzM6GzFBeU1/6IV/npKP5ORtp9zbQjvkDJ47s6BCgaAZnnnu/cY1x342+MvZg==", + "cpu": [ + "arm64" + ], + "license": "MIT", + "optional": true, + "os": [ + "openbsd" + ], + "engines": { + "node": ">=18" + } + }, + "node_modules/@esbuild/openbsd-x64": { + "version": "0.25.1", + "resolved": "https://registry.npmjs.org/@esbuild/openbsd-x64/-/openbsd-x64-0.25.1.tgz", + "integrity": "sha512-T3H78X2h1tszfRSf+txbt5aOp/e7TAz3ptVKu9Oyir3IAOFPGV6O9c2naym5TOriy1l0nNf6a4X5UXRZSGX/dw==", + "cpu": [ + "x64" + ], + "license": "MIT", + "optional": true, + "os": [ + "openbsd" + ], + "engines": { + "node": ">=18" + } + }, + "node_modules/@esbuild/sunos-x64": { + "version": "0.25.1", + "resolved": "https://registry.npmjs.org/@esbuild/sunos-x64/-/sunos-x64-0.25.1.tgz", + "integrity": "sha512-2H3RUvcmULO7dIE5EWJH8eubZAI4xw54H1ilJnRNZdeo8dTADEZ21w6J22XBkXqGJbe0+wnNJtw3UXRoLJnFEg==", + "cpu": [ + "x64" + ], + "license": "MIT", + "optional": true, + "os": [ + "sunos" + ], + "engines": { + "node": ">=18" + } + }, + "node_modules/@esbuild/win32-arm64": { + "version": "0.25.1", + "resolved": "https://registry.npmjs.org/@esbuild/win32-arm64/-/win32-arm64-0.25.1.tgz", + "integrity": "sha512-GE7XvrdOzrb+yVKB9KsRMq+7a2U/K5Cf/8grVFRAGJmfADr/e/ODQ134RK2/eeHqYV5eQRFxb1hY7Nr15fv1NQ==", + "cpu": [ + "arm64" + ], + "license": "MIT", + "optional": true, + "os": [ + "win32" + ], + "engines": { + "node": ">=18" + } + }, + "node_modules/@esbuild/win32-ia32": { + "version": "0.25.1", + "resolved": "https://registry.npmjs.org/@esbuild/win32-ia32/-/win32-ia32-0.25.1.tgz", + "integrity": "sha512-uOxSJCIcavSiT6UnBhBzE8wy3n0hOkJsBOzy7HDAuTDE++1DJMRRVCPGisULScHL+a/ZwdXPpXD3IyFKjA7K8A==", + "cpu": [ + "ia32" + ], + "license": "MIT", + "optional": true, + "os": [ + "win32" + ], + "engines": { + "node": ">=18" + } + }, + "node_modules/@esbuild/win32-x64": { + "version": "0.25.1", + "resolved": "https://registry.npmjs.org/@esbuild/win32-x64/-/win32-x64-0.25.1.tgz", + "integrity": "sha512-Y1EQdcfwMSeQN/ujR5VayLOJ1BHaK+ssyk0AEzPjC+t1lITgsnccPqFjb6V+LsTp/9Iov4ysfjxLaGJ9RPtkVg==", + "cpu": [ + "x64" + ], + "license": "MIT", + "optional": true, + "os": [ + "win32" + ], + "engines": { + "node": ">=18" + } + }, + "node_modules/@types/http-proxy": { + "version": "1.17.16", + "resolved": "https://registry.npmjs.org/@types/http-proxy/-/http-proxy-1.17.16.tgz", + "integrity": "sha512-sdWoUajOB1cd0A8cRRQ1cfyWNbmFKLAqBB89Y8x5iYyG/mkJHc0YUH8pdWBy2omi9qtCpiIgGjuwO0dQST2l5w==", + "license": "MIT", + "dependencies": { + "@types/node": "*" + } + }, + "node_modules/@types/node": { + "version": "22.13.14", + "resolved": "https://registry.npmjs.org/@types/node/-/node-22.13.14.tgz", + "integrity": "sha512-Zs/Ollc1SJ8nKUAgc7ivOEdIBM8JAKgrqqUYi2J997JuKO7/tpQC+WCetQ1sypiKCQWHdvdg9wBNpUPEWZae7w==", + "license": "MIT", + "dependencies": { + "undici-types": "~6.20.0" + } + }, + "node_modules/accepts": { + "version": "1.3.8", + "resolved": "https://registry.npmjs.org/accepts/-/accepts-1.3.8.tgz", + "integrity": "sha512-PYAthTa2m2VKxuvSD3DPC/Gy+U+sOA1LAuT8mkmRuvw+NACSaeXEQ+NHcVF7rONl6qcaxV3Uuemwawk+7+SJLw==", + "license": "MIT", + "dependencies": { + "mime-types": "~2.1.34", + "negotiator": "0.6.3" + }, + "engines": { + "node": ">= 0.6" + } + }, + "node_modules/array-flatten": { + "version": "1.1.1", + "resolved": "https://registry.npmjs.org/array-flatten/-/array-flatten-1.1.1.tgz", + "integrity": "sha512-PCVAQswWemu6UdxsDFFX/+gVeYqKAod3D3UVm91jHwynguOwAvYPhx8nNlM++NqRcK6CxxpUafjmhIdKiHibqg==", + "license": "MIT" + }, + "node_modules/body-parser": { + "version": "1.20.3", + "resolved": "https://registry.npmjs.org/body-parser/-/body-parser-1.20.3.tgz", + "integrity": "sha512-7rAxByjUMqQ3/bHJy7D6OGXvx/MMc4IqBn/X0fcM1QUcAItpZrBEYhWGem+tzXH90c+G01ypMcYJBO9Y30203g==", + "license": "MIT", + "dependencies": { + "bytes": "3.1.2", + "content-type": "~1.0.5", + "debug": "2.6.9", + "depd": "2.0.0", + "destroy": "1.2.0", + "http-errors": "2.0.0", + "iconv-lite": "0.4.24", + "on-finished": "2.4.1", + "qs": "6.13.0", + "raw-body": "2.5.2", + "type-is": "~1.6.18", + "unpipe": "1.0.0" + }, + "engines": { + "node": ">= 0.8", + "npm": "1.2.8000 || >= 1.4.16" + } + }, + "node_modules/braces": { + "version": "3.0.3", + "resolved": "https://registry.npmjs.org/braces/-/braces-3.0.3.tgz", + "integrity": "sha512-yQbXgO/OSZVD2IsiLlro+7Hf6Q18EJrKSEsdoMzKePKXct3gvD8oLcOQdIzGupr5Fj+EDe8gO/lxc1BzfMpxvA==", + "license": "MIT", + "dependencies": { + "fill-range": "^7.1.1" + }, + "engines": { + "node": ">=8" + } + }, + "node_modules/bytes": { + "version": "3.1.2", + "resolved": "https://registry.npmjs.org/bytes/-/bytes-3.1.2.tgz", + "integrity": "sha512-/Nf7TyzTx6S3yRJObOAV7956r8cr2+Oj8AC5dt8wSP3BQAoeX58NoHyCU8P8zGkNXStjTSi6fzO6F0pBdcYbEg==", + "license": "MIT", + "engines": { + "node": ">= 0.8" + } + }, + "node_modules/call-bind-apply-helpers": { + "version": "1.0.2", + "resolved": "https://registry.npmjs.org/call-bind-apply-helpers/-/call-bind-apply-helpers-1.0.2.tgz", + "integrity": "sha512-Sp1ablJ0ivDkSzjcaJdxEunN5/XvksFJ2sMBFfq6x0ryhQV/2b/KwFe21cMpmHtPOSij8K99/wSfoEuTObmuMQ==", + "license": "MIT", + "dependencies": { + "es-errors": "^1.3.0", + "function-bind": "^1.1.2" + }, + "engines": { + "node": ">= 0.4" + } + }, + "node_modules/call-bound": { + "version": "1.0.4", + "resolved": "https://registry.npmjs.org/call-bound/-/call-bound-1.0.4.tgz", + "integrity": "sha512-+ys997U96po4Kx/ABpBCqhA9EuxJaQWDQg7295H4hBphv3IZg0boBKuwYpt4YXp6MZ5AmZQnU/tyMTlRpaSejg==", + "license": "MIT", + "dependencies": { + "call-bind-apply-helpers": "^1.0.2", + "get-intrinsic": "^1.3.0" + }, + "engines": { + "node": ">= 0.4" + }, + "funding": { + "url": "https://github.com/sponsors/ljharb" + } + }, + "node_modules/content-disposition": { + "version": "0.5.4", + "resolved": "https://registry.npmjs.org/content-disposition/-/content-disposition-0.5.4.tgz", + "integrity": "sha512-FveZTNuGw04cxlAiWbzi6zTAL/lhehaWbTtgluJh4/E95DqMwTmha3KZN1aAWA8cFIhHzMZUvLevkw5Rqk+tSQ==", + "license": "MIT", + "dependencies": { + "safe-buffer": "5.2.1" + }, + "engines": { + "node": ">= 0.6" + } + }, + "node_modules/content-type": { + "version": "1.0.5", + "resolved": "https://registry.npmjs.org/content-type/-/content-type-1.0.5.tgz", + "integrity": "sha512-nTjqfcBFEipKdXCv4YDQWCfmcLZKm81ldF0pAopTvyrFGVbcR6P/VAAd5G7N+0tTr8QqiU0tFadD6FK4NtJwOA==", + "license": "MIT", + "engines": { + "node": ">= 0.6" + } + }, + "node_modules/cookie": { + "version": "0.7.1", + "resolved": "https://registry.npmjs.org/cookie/-/cookie-0.7.1.tgz", + "integrity": "sha512-6DnInpx7SJ2AK3+CTUE/ZM0vWTUboZCegxhC2xiIydHR9jNuTAASBrfEpHhiGOZw/nX51bHt6YQl8jsGo4y/0w==", + "license": "MIT", + "engines": { + "node": ">= 0.6" + } + }, + "node_modules/cookie-signature": { + "version": "1.0.6", + "resolved": "https://registry.npmjs.org/cookie-signature/-/cookie-signature-1.0.6.tgz", + "integrity": "sha512-QADzlaHc8icV8I7vbaJXJwod9HWYp8uCqf1xa4OfNu1T7JVxQIrUgOWtHdNDtPiywmFbiS12VjotIXLrKM3orQ==", + "license": "MIT" + }, + "node_modules/cors": { + "version": "2.8.5", + "resolved": "https://registry.npmjs.org/cors/-/cors-2.8.5.tgz", + "integrity": "sha512-KIHbLJqu73RGr/hnbrO9uBeixNGuvSQjul/jdFvS/KFSIH1hWVd1ng7zOHx+YrEfInLG7q4n6GHQ9cDtxv/P6g==", + "license": "MIT", + "dependencies": { + "object-assign": "^4", + "vary": "^1" + }, + "engines": { + "node": ">= 0.10" + } + }, + "node_modules/debug": { + "version": "2.6.9", + "resolved": "https://registry.npmjs.org/debug/-/debug-2.6.9.tgz", + "integrity": "sha512-bC7ElrdJaJnPbAP+1EotYvqZsb3ecl5wi6Bfi6BJTUcNowp6cvspg0jXznRTKDjm/E7AdgFBVeAPVMNcKGsHMA==", + "license": "MIT", + "dependencies": { + "ms": "2.0.0" + } + }, + "node_modules/depd": { + "version": "2.0.0", + "resolved": "https://registry.npmjs.org/depd/-/depd-2.0.0.tgz", + "integrity": "sha512-g7nH6P6dyDioJogAAGprGpCtVImJhpPk/roCzdb3fIh61/s/nPsfR6onyMwkCAR/OlC3yBC0lESvUoQEAssIrw==", + "license": "MIT", + "engines": { + "node": ">= 0.8" + } + }, + "node_modules/destroy": { + "version": "1.2.0", + "resolved": "https://registry.npmjs.org/destroy/-/destroy-1.2.0.tgz", + "integrity": "sha512-2sJGJTaXIIaR1w4iJSNoN0hnMY7Gpc/n8D4qSCJw8QqFWXf7cuAgnEHxBpweaVcPevC2l3KpjYCx3NypQQgaJg==", + "license": "MIT", + "engines": { + "node": ">= 0.8", + "npm": "1.2.8000 || >= 1.4.16" + } + }, + "node_modules/dunder-proto": { + "version": "1.0.1", + "resolved": "https://registry.npmjs.org/dunder-proto/-/dunder-proto-1.0.1.tgz", + "integrity": "sha512-KIN/nDJBQRcXw0MLVhZE9iQHmG68qAVIBg9CqmUYjmQIhgij9U5MFvrqkUL5FbtyyzZuOeOt0zdeRe4UY7ct+A==", + "license": "MIT", + "dependencies": { + "call-bind-apply-helpers": "^1.0.1", + "es-errors": "^1.3.0", + "gopd": "^1.2.0" + }, + "engines": { + "node": ">= 0.4" + } + }, + "node_modules/ee-first": { + "version": "1.1.1", + "resolved": "https://registry.npmjs.org/ee-first/-/ee-first-1.1.1.tgz", + "integrity": "sha512-WMwm9LhRUo+WUaRN+vRuETqG89IgZphVSNkdFgeb6sS/E4OrDIN7t48CAewSHXc6C8lefD8KKfr5vY61brQlow==", + "license": "MIT" + }, + "node_modules/encodeurl": { + "version": "2.0.0", + "resolved": "https://registry.npmjs.org/encodeurl/-/encodeurl-2.0.0.tgz", + "integrity": "sha512-Q0n9HRi4m6JuGIV1eFlmvJB7ZEVxu93IrMyiMsGC0lrMJMWzRgx6WGquyfQgZVb31vhGgXnfmPNNXmxnOkRBrg==", + "license": "MIT", + "engines": { + "node": ">= 0.8" + } + }, + "node_modules/es-define-property": { + "version": "1.0.1", + "resolved": "https://registry.npmjs.org/es-define-property/-/es-define-property-1.0.1.tgz", + "integrity": "sha512-e3nRfgfUZ4rNGL232gUgX06QNyyez04KdjFrF+LTRoOXmrOgFKDg4BCdsjW8EnT69eqdYGmRpJwiPVYNrCaW3g==", + "license": "MIT", + "engines": { + "node": ">= 0.4" + } + }, + "node_modules/es-errors": { + "version": "1.3.0", + "resolved": "https://registry.npmjs.org/es-errors/-/es-errors-1.3.0.tgz", + "integrity": "sha512-Zf5H2Kxt2xjTvbJvP2ZWLEICxA6j+hAmMzIlypy4xcBg1vKVnx89Wy0GbS+kf5cwCVFFzdCFh2XSCFNULS6csw==", + "license": "MIT", + "engines": { + "node": ">= 0.4" + } + }, + "node_modules/es-object-atoms": { + "version": "1.1.1", + "resolved": "https://registry.npmjs.org/es-object-atoms/-/es-object-atoms-1.1.1.tgz", + "integrity": "sha512-FGgH2h8zKNim9ljj7dankFPcICIK9Cp5bm+c2gQSYePhpaG5+esrLODihIorn+Pe6FGJzWhXQotPv73jTaldXA==", + "license": "MIT", + "dependencies": { + "es-errors": "^1.3.0" + }, + "engines": { + "node": ">= 0.4" + } + }, + "node_modules/esbuild": { + "version": "0.25.1", + "resolved": "https://registry.npmjs.org/esbuild/-/esbuild-0.25.1.tgz", + "integrity": "sha512-BGO5LtrGC7vxnqucAe/rmvKdJllfGaYWdyABvyMoXQlfYMb2bbRuReWR5tEGE//4LcNJj9XrkovTqNYRFZHAMQ==", + "hasInstallScript": true, + "license": "MIT", + "bin": { + "esbuild": "bin/esbuild" + }, + "engines": { + "node": ">=18" + }, + "optionalDependencies": { + "@esbuild/aix-ppc64": "0.25.1", + "@esbuild/android-arm": "0.25.1", + "@esbuild/android-arm64": "0.25.1", + "@esbuild/android-x64": "0.25.1", + "@esbuild/darwin-arm64": "0.25.1", + "@esbuild/darwin-x64": "0.25.1", + "@esbuild/freebsd-arm64": "0.25.1", + "@esbuild/freebsd-x64": "0.25.1", + "@esbuild/linux-arm": "0.25.1", + "@esbuild/linux-arm64": "0.25.1", + "@esbuild/linux-ia32": "0.25.1", + "@esbuild/linux-loong64": "0.25.1", + "@esbuild/linux-mips64el": "0.25.1", + "@esbuild/linux-ppc64": "0.25.1", + "@esbuild/linux-riscv64": "0.25.1", + "@esbuild/linux-s390x": "0.25.1", + "@esbuild/linux-x64": "0.25.1", + "@esbuild/netbsd-arm64": "0.25.1", + "@esbuild/netbsd-x64": "0.25.1", + "@esbuild/openbsd-arm64": "0.25.1", + "@esbuild/openbsd-x64": "0.25.1", + "@esbuild/sunos-x64": "0.25.1", + "@esbuild/win32-arm64": "0.25.1", + "@esbuild/win32-ia32": "0.25.1", + "@esbuild/win32-x64": "0.25.1" + } + }, + "node_modules/escape-html": { + "version": "1.0.3", + "resolved": "https://registry.npmjs.org/escape-html/-/escape-html-1.0.3.tgz", + "integrity": "sha512-NiSupZ4OeuGwr68lGIeym/ksIZMJodUGOSCZ/FSnTxcrekbvqrgdUxlJOMpijaKZVjAJrWrGs/6Jy8OMuyj9ow==", + "license": "MIT" + }, + "node_modules/etag": { + "version": "1.8.1", + "resolved": "https://registry.npmjs.org/etag/-/etag-1.8.1.tgz", + "integrity": "sha512-aIL5Fx7mawVa300al2BnEE4iNvo1qETxLrPI/o05L7z6go7fCw1J6EQmbK4FmJ2AS7kgVF/KEZWufBfdClMcPg==", + "license": "MIT", + "engines": { + "node": ">= 0.6" + } + }, + "node_modules/eventemitter3": { + "version": "4.0.7", + "resolved": "https://registry.npmjs.org/eventemitter3/-/eventemitter3-4.0.7.tgz", + "integrity": "sha512-8guHBZCwKnFhYdHr2ysuRWErTwhoN2X8XELRlrRwpmfeY2jjuUN4taQMsULKUVo1K4DvZl+0pgfyoysHxvmvEw==", + "license": "MIT" + }, + "node_modules/express": { + "version": "4.21.2", + "resolved": "https://registry.npmjs.org/express/-/express-4.21.2.tgz", + "integrity": "sha512-28HqgMZAmih1Czt9ny7qr6ek2qddF4FclbMzwhCREB6OFfH+rXAnuNCwo1/wFvrtbgsQDb4kSbX9de9lFbrXnA==", + "license": "MIT", + "dependencies": { + "accepts": "~1.3.8", + "array-flatten": "1.1.1", + "body-parser": "1.20.3", + "content-disposition": "0.5.4", + "content-type": "~1.0.4", + "cookie": "0.7.1", + "cookie-signature": "1.0.6", + "debug": "2.6.9", + "depd": "2.0.0", + "encodeurl": "~2.0.0", + "escape-html": "~1.0.3", + "etag": "~1.8.1", + "finalhandler": "1.3.1", + "fresh": "0.5.2", + "http-errors": "2.0.0", + "merge-descriptors": "1.0.3", + "methods": "~1.1.2", + "on-finished": "2.4.1", + "parseurl": "~1.3.3", + "path-to-regexp": "0.1.12", + "proxy-addr": "~2.0.7", + "qs": "6.13.0", + "range-parser": "~1.2.1", + "safe-buffer": "5.2.1", + "send": "0.19.0", + "serve-static": "1.16.2", + "setprototypeof": "1.2.0", + "statuses": "2.0.1", + "type-is": "~1.6.18", + "utils-merge": "1.0.1", + "vary": "~1.1.2" + }, + "engines": { + "node": ">= 0.10.0" + }, + "funding": { + "type": "opencollective", + "url": "https://opencollective.com/express" + } + }, + "node_modules/fill-range": { + "version": "7.1.1", + "resolved": "https://registry.npmjs.org/fill-range/-/fill-range-7.1.1.tgz", + "integrity": "sha512-YsGpe3WHLK8ZYi4tWDg2Jy3ebRz2rXowDxnld4bkQB00cc/1Zw9AWnC0i9ztDJitivtQvaI9KaLyKrc+hBW0yg==", + "license": "MIT", + "dependencies": { + "to-regex-range": "^5.0.1" + }, + "engines": { + "node": ">=8" + } + }, + "node_modules/finalhandler": { + "version": "1.3.1", + "resolved": "https://registry.npmjs.org/finalhandler/-/finalhandler-1.3.1.tgz", + "integrity": "sha512-6BN9trH7bp3qvnrRyzsBz+g3lZxTNZTbVO2EV1CS0WIcDbawYVdYvGflME/9QP0h0pYlCDBCTjYa9nZzMDpyxQ==", + "license": "MIT", + "dependencies": { + "debug": "2.6.9", + "encodeurl": "~2.0.0", + "escape-html": "~1.0.3", + "on-finished": "2.4.1", + "parseurl": "~1.3.3", + "statuses": "2.0.1", + "unpipe": "~1.0.0" + }, + "engines": { + "node": ">= 0.8" + } + }, + "node_modules/follow-redirects": { + "version": "1.15.9", + "resolved": "https://registry.npmjs.org/follow-redirects/-/follow-redirects-1.15.9.tgz", + "integrity": "sha512-gew4GsXizNgdoRyqmyfMHyAmXsZDk6mHkSxZFCzW9gwlbtOW44CDtYavM+y+72qD/Vq2l550kMF52DT8fOLJqQ==", + "funding": [ + { + "type": "individual", + "url": "https://github.com/sponsors/RubenVerborgh" + } + ], + "license": "MIT", + "engines": { + "node": ">=4.0" + }, + "peerDependenciesMeta": { + "debug": { + "optional": true + } + } + }, + "node_modules/forwarded": { + "version": "0.2.0", + "resolved": "https://registry.npmjs.org/forwarded/-/forwarded-0.2.0.tgz", + "integrity": "sha512-buRG0fpBtRHSTCOASe6hD258tEubFoRLb4ZNA6NxMVHNw2gOcwHo9wyablzMzOA5z9xA9L1KNjk/Nt6MT9aYow==", + "license": "MIT", + "engines": { + "node": ">= 0.6" + } + }, + "node_modules/fresh": { + "version": "0.5.2", + "resolved": "https://registry.npmjs.org/fresh/-/fresh-0.5.2.tgz", + "integrity": "sha512-zJ2mQYM18rEFOudeV4GShTGIQ7RbzA7ozbU9I/XBpm7kqgMywgmylMwXHxZJmkVoYkna9d2pVXVXPdYTP9ej8Q==", + "license": "MIT", + "engines": { + "node": ">= 0.6" + } + }, + "node_modules/function-bind": { + "version": "1.1.2", + "resolved": "https://registry.npmjs.org/function-bind/-/function-bind-1.1.2.tgz", + "integrity": "sha512-7XHNxH7qX9xG5mIwxkhumTox/MIRNcOgDrxWsMt2pAr23WHp6MrRlN7FBSFpCpr+oVO0F744iUgR82nJMfG2SA==", + "license": "MIT", + "funding": { + "url": "https://github.com/sponsors/ljharb" + } + }, + "node_modules/get-intrinsic": { + "version": "1.3.0", + "resolved": "https://registry.npmjs.org/get-intrinsic/-/get-intrinsic-1.3.0.tgz", + "integrity": "sha512-9fSjSaos/fRIVIp+xSJlE6lfwhES7LNtKaCBIamHsjr2na1BiABJPo0mOjjz8GJDURarmCPGqaiVg5mfjb98CQ==", + "license": "MIT", + "dependencies": { + "call-bind-apply-helpers": "^1.0.2", + "es-define-property": "^1.0.1", + "es-errors": "^1.3.0", + "es-object-atoms": "^1.1.1", + "function-bind": "^1.1.2", + "get-proto": "^1.0.1", + "gopd": "^1.2.0", + "has-symbols": "^1.1.0", + "hasown": "^2.0.2", + "math-intrinsics": "^1.1.0" + }, + "engines": { + "node": ">= 0.4" + }, + "funding": { + "url": "https://github.com/sponsors/ljharb" + } + }, + "node_modules/get-proto": { + "version": "1.0.1", + "resolved": "https://registry.npmjs.org/get-proto/-/get-proto-1.0.1.tgz", + "integrity": "sha512-sTSfBjoXBp89JvIKIefqw7U2CCebsc74kiY6awiGogKtoSGbgjYE/G/+l9sF3MWFPNc9IcoOC4ODfKHfxFmp0g==", + "license": "MIT", + "dependencies": { + "dunder-proto": "^1.0.1", + "es-object-atoms": "^1.0.0" + }, + "engines": { + "node": ">= 0.4" + } + }, + "node_modules/gopd": { + "version": "1.2.0", + "resolved": "https://registry.npmjs.org/gopd/-/gopd-1.2.0.tgz", + "integrity": "sha512-ZUKRh6/kUFoAiTAtTYPZJ3hw9wNxx+BIBOijnlG9PnrJsCcSjs1wyyD6vJpaYtgnzDrKYRSqf3OO6Rfa93xsRg==", + "license": "MIT", + "engines": { + "node": ">= 0.4" + }, + "funding": { + "url": "https://github.com/sponsors/ljharb" + } + }, + "node_modules/guida": { + "resolved": "..", + "link": true + }, + "node_modules/has-symbols": { + "version": "1.1.0", + "resolved": "https://registry.npmjs.org/has-symbols/-/has-symbols-1.1.0.tgz", + "integrity": "sha512-1cDNdwJ2Jaohmb3sg4OmKaMBwuC48sYni5HUw2DvsC8LjGTLK9h+eb1X6RyuOHe4hT0ULCW68iomhjUoKUqlPQ==", + "license": "MIT", + "engines": { + "node": ">= 0.4" + }, + "funding": { + "url": "https://github.com/sponsors/ljharb" + } + }, + "node_modules/hasown": { + "version": "2.0.2", + "resolved": "https://registry.npmjs.org/hasown/-/hasown-2.0.2.tgz", + "integrity": "sha512-0hJU9SCPvmMzIBdZFqNPXWa6dqh7WdH0cII9y+CyS8rG3nL48Bclra9HmKhVVUHyPWNH5Y7xDwAB7bfgSjkUMQ==", + "license": "MIT", + "dependencies": { + "function-bind": "^1.1.2" + }, + "engines": { + "node": ">= 0.4" + } + }, + "node_modules/http-errors": { + "version": "2.0.0", + "resolved": "https://registry.npmjs.org/http-errors/-/http-errors-2.0.0.tgz", + "integrity": "sha512-FtwrG/euBzaEjYeRqOgly7G0qviiXoJWnvEH2Z1plBdXgbyjv34pHTSb9zoeHMyDy33+DWy5Wt9Wo+TURtOYSQ==", + "license": "MIT", + "dependencies": { + "depd": "2.0.0", + "inherits": "2.0.4", + "setprototypeof": "1.2.0", + "statuses": "2.0.1", + "toidentifier": "1.0.1" + }, + "engines": { + "node": ">= 0.8" + } + }, + "node_modules/http-proxy": { + "version": "1.18.1", + "resolved": "https://registry.npmjs.org/http-proxy/-/http-proxy-1.18.1.tgz", + "integrity": "sha512-7mz/721AbnJwIVbnaSv1Cz3Am0ZLT/UBwkC92VlxhXv/k/BBQfM2fXElQNC27BVGr0uwUpplYPQM9LnaBMR5NQ==", + "license": "MIT", + "dependencies": { + "eventemitter3": "^4.0.0", + "follow-redirects": "^1.0.0", + "requires-port": "^1.0.0" + }, + "engines": { + "node": ">=8.0.0" + } + }, + "node_modules/http-proxy-middleware": { + "version": "3.0.3", + "resolved": "https://registry.npmjs.org/http-proxy-middleware/-/http-proxy-middleware-3.0.3.tgz", + "integrity": "sha512-usY0HG5nyDUwtqpiZdETNbmKtw3QQ1jwYFZ9wi5iHzX2BcILwQKtYDJPo7XHTsu5Z0B2Hj3W9NNnbd+AjFWjqg==", + "license": "MIT", + "dependencies": { + "@types/http-proxy": "^1.17.15", + "debug": "^4.3.6", + "http-proxy": "^1.18.1", + "is-glob": "^4.0.3", + "is-plain-object": "^5.0.0", + "micromatch": "^4.0.8" + }, + "engines": { + "node": "^14.15.0 || ^16.10.0 || >=18.0.0" + } + }, + "node_modules/http-proxy-middleware/node_modules/debug": { + "version": "4.4.0", + "resolved": "https://registry.npmjs.org/debug/-/debug-4.4.0.tgz", + "integrity": "sha512-6WTZ/IxCY/T6BALoZHaE4ctp9xm+Z5kY/pzYaCHRFeyVhojxlrm+46y68HA6hr0TcwEssoxNiDEUJQjfPZ/RYA==", + "license": "MIT", + "dependencies": { + "ms": "^2.1.3" + }, + "engines": { + "node": ">=6.0" + }, + "peerDependenciesMeta": { + "supports-color": { + "optional": true + } + } + }, + "node_modules/http-proxy-middleware/node_modules/ms": { + "version": "2.1.3", + "resolved": "https://registry.npmjs.org/ms/-/ms-2.1.3.tgz", + "integrity": "sha512-6FlzubTLZG3J2a/NVCAleEhjzq5oxgHyaCU9yYXvcLsvoVaHJq/s5xXI6/XXP6tz7R9xAOtHnSO/tXtF3WRTlA==", + "license": "MIT" + }, + "node_modules/iconv-lite": { + "version": "0.4.24", + "resolved": "https://registry.npmjs.org/iconv-lite/-/iconv-lite-0.4.24.tgz", + "integrity": "sha512-v3MXnZAcvnywkTUEZomIActle7RXXeedOR31wwl7VlyoXO4Qi9arvSenNQWne1TcRwhCL1HwLI21bEqdpj8/rA==", + "license": "MIT", + "dependencies": { + "safer-buffer": ">= 2.1.2 < 3" + }, + "engines": { + "node": ">=0.10.0" + } + }, + "node_modules/inherits": { + "version": "2.0.4", + "resolved": "https://registry.npmjs.org/inherits/-/inherits-2.0.4.tgz", + "integrity": "sha512-k/vGaX4/Yla3WzyMCvTQOXYeIHvqOKtnqBduzTHpzpQZzAskKMhZ2K+EnBiSM9zGSoIFeMpXKxa4dYeZIQqewQ==", + "license": "ISC" + }, + "node_modules/ipaddr.js": { + "version": "1.9.1", + "resolved": "https://registry.npmjs.org/ipaddr.js/-/ipaddr.js-1.9.1.tgz", + "integrity": "sha512-0KI/607xoxSToH7GjN1FfSbLoU0+btTicjsQSWQlh/hZykN8KpmMf7uYwPW3R+akZ6R/w18ZlXSHBYXiYUPO3g==", + "license": "MIT", + "engines": { + "node": ">= 0.10" + } + }, + "node_modules/is-extglob": { + "version": "2.1.1", + "resolved": "https://registry.npmjs.org/is-extglob/-/is-extglob-2.1.1.tgz", + "integrity": "sha512-SbKbANkN603Vi4jEZv49LeVJMn4yGwsbzZworEoyEiutsN3nJYdbO36zfhGJ6QEDpOZIFkDtnq5JRxmvl3jsoQ==", + "license": "MIT", + "engines": { + "node": ">=0.10.0" + } + }, + "node_modules/is-glob": { + "version": "4.0.3", + "resolved": "https://registry.npmjs.org/is-glob/-/is-glob-4.0.3.tgz", + "integrity": "sha512-xelSayHH36ZgE7ZWhli7pW34hNbNl8Ojv5KVmkJD4hBdD3th8Tfk9vYasLM+mXWOZhFkgZfxhLSnrwRr4elSSg==", + "license": "MIT", + "dependencies": { + "is-extglob": "^2.1.1" + }, + "engines": { + "node": ">=0.10.0" + } + }, + "node_modules/is-number": { + "version": "7.0.0", + "resolved": "https://registry.npmjs.org/is-number/-/is-number-7.0.0.tgz", + "integrity": "sha512-41Cifkg6e8TylSpdtTpeLVMqvSBEVzTttHvERD741+pnZ8ANv0004MRL43QKPDlK9cGvNp6NZWZUBlbGXYxxng==", + "license": "MIT", + "engines": { + "node": ">=0.12.0" + } + }, + "node_modules/is-plain-object": { + "version": "5.0.0", + "resolved": "https://registry.npmjs.org/is-plain-object/-/is-plain-object-5.0.0.tgz", + "integrity": "sha512-VRSzKkbMm5jMDoKLbltAkFQ5Qr7VDiTFGXxYFXXowVj387GeGNOCsOH6Msy00SGZ3Fp84b1Naa1psqgcCIEP5Q==", + "license": "MIT", + "engines": { + "node": ">=0.10.0" + } + }, + "node_modules/math-intrinsics": { + "version": "1.1.0", + "resolved": "https://registry.npmjs.org/math-intrinsics/-/math-intrinsics-1.1.0.tgz", + "integrity": "sha512-/IXtbwEk5HTPyEwyKX6hGkYXxM9nbj64B+ilVJnC/R6B0pH5G4V3b0pVbL7DBj4tkhBAppbQUlf6F6Xl9LHu1g==", + "license": "MIT", + "engines": { + "node": ">= 0.4" + } + }, + "node_modules/media-typer": { + "version": "0.3.0", + "resolved": "https://registry.npmjs.org/media-typer/-/media-typer-0.3.0.tgz", + "integrity": "sha512-dq+qelQ9akHpcOl/gUVRTxVIOkAJ1wR3QAvb4RsVjS8oVoFjDGTc679wJYmUmknUF5HwMLOgb5O+a3KxfWapPQ==", + "license": "MIT", + "engines": { + "node": ">= 0.6" + } + }, + "node_modules/merge-descriptors": { + "version": "1.0.3", + "resolved": "https://registry.npmjs.org/merge-descriptors/-/merge-descriptors-1.0.3.tgz", + "integrity": "sha512-gaNvAS7TZ897/rVaZ0nMtAyxNyi/pdbjbAwUpFQpN70GqnVfOiXpeUUMKRBmzXaSQ8DdTX4/0ms62r2K+hE6mQ==", + "license": "MIT", + "funding": { + "url": "https://github.com/sponsors/sindresorhus" + } + }, + "node_modules/methods": { + "version": "1.1.2", + "resolved": "https://registry.npmjs.org/methods/-/methods-1.1.2.tgz", + "integrity": "sha512-iclAHeNqNm68zFtnZ0e+1L2yUIdvzNoauKU4WBA3VvH/vPFieF7qfRlwUZU+DA9P9bPXIS90ulxoUoCH23sV2w==", + "license": "MIT", + "engines": { + "node": ">= 0.6" + } + }, + "node_modules/micromatch": { + "version": "4.0.8", + "resolved": "https://registry.npmjs.org/micromatch/-/micromatch-4.0.8.tgz", + "integrity": "sha512-PXwfBhYu0hBCPw8Dn0E+WDYb7af3dSLVWKi3HGv84IdF4TyFoC0ysxFd0Goxw7nSv4T/PzEJQxsYsEiFCKo2BA==", + "license": "MIT", + "dependencies": { + "braces": "^3.0.3", + "picomatch": "^2.3.1" + }, + "engines": { + "node": ">=8.6" + } + }, + "node_modules/mime": { + "version": "1.6.0", + "resolved": "https://registry.npmjs.org/mime/-/mime-1.6.0.tgz", + "integrity": "sha512-x0Vn8spI+wuJ1O6S7gnbaQg8Pxh4NNHb7KSINmEWKiPE4RKOplvijn+NkmYmmRgP68mc70j2EbeTFRsrswaQeg==", + "license": "MIT", + "bin": { + "mime": "cli.js" + }, + "engines": { + "node": ">=4" + } + }, + "node_modules/mime-db": { + "version": "1.52.0", + "resolved": "https://registry.npmjs.org/mime-db/-/mime-db-1.52.0.tgz", + "integrity": "sha512-sPU4uV7dYlvtWJxwwxHD0PuihVNiE7TyAbQ5SWxDCB9mUYvOgroQOwYQQOKPJ8CIbE+1ETVlOoK1UC2nU3gYvg==", + "license": "MIT", + "engines": { + "node": ">= 0.6" + } + }, + "node_modules/mime-types": { + "version": "2.1.35", + "resolved": "https://registry.npmjs.org/mime-types/-/mime-types-2.1.35.tgz", + "integrity": "sha512-ZDY+bPm5zTTF+YpCrAU9nK0UgICYPT0QtT1NZWFv4s++TNkcgVaT0g6+4R2uI4MjQjzysHB1zxuWL50hzaeXiw==", + "license": "MIT", + "dependencies": { + "mime-db": "1.52.0" + }, + "engines": { + "node": ">= 0.6" + } + }, + "node_modules/ms": { + "version": "2.0.0", + "resolved": "https://registry.npmjs.org/ms/-/ms-2.0.0.tgz", + "integrity": "sha512-Tpp60P6IUJDTuOq/5Z8cdskzJujfwqfOTkrwIwj7IRISpnkJnT6SyJ4PCPnGMoFjC9ddhal5KVIYtAt97ix05A==", + "license": "MIT" + }, + "node_modules/negotiator": { + "version": "0.6.3", + "resolved": "https://registry.npmjs.org/negotiator/-/negotiator-0.6.3.tgz", + "integrity": "sha512-+EUsqGPLsM+j/zdChZjsnX51g4XrHFOIXwfnCVPGlQk/k5giakcKsuxCObBRu6DSm9opw/O6slWbJdghQM4bBg==", + "license": "MIT", + "engines": { + "node": ">= 0.6" + } + }, + "node_modules/object-assign": { + "version": "4.1.1", + "resolved": "https://registry.npmjs.org/object-assign/-/object-assign-4.1.1.tgz", + "integrity": "sha512-rJgTQnkUnH1sFw8yT6VSU3zD3sWmu6sZhIseY8VX+GRu3P6F7Fu+JNDoXfklElbLJSnc3FUQHVe4cU5hj+BcUg==", + "license": "MIT", + "engines": { + "node": ">=0.10.0" + } + }, + "node_modules/object-inspect": { + "version": "1.13.4", + "resolved": "https://registry.npmjs.org/object-inspect/-/object-inspect-1.13.4.tgz", + "integrity": "sha512-W67iLl4J2EXEGTbfeHCffrjDfitvLANg0UlX3wFUUSTx92KXRFegMHUVgSqE+wvhAbi4WqjGg9czysTV2Epbew==", + "license": "MIT", + "engines": { + "node": ">= 0.4" + }, + "funding": { + "url": "https://github.com/sponsors/ljharb" + } + }, + "node_modules/on-finished": { + "version": "2.4.1", + "resolved": "https://registry.npmjs.org/on-finished/-/on-finished-2.4.1.tgz", + "integrity": "sha512-oVlzkg3ENAhCk2zdv7IJwd/QUD4z2RxRwpkcGY8psCVcCYZNq4wYnVWALHM+brtuJjePWiYF/ClmuDr8Ch5+kg==", + "license": "MIT", + "dependencies": { + "ee-first": "1.1.1" + }, + "engines": { + "node": ">= 0.8" + } + }, + "node_modules/parseurl": { + "version": "1.3.3", + "resolved": "https://registry.npmjs.org/parseurl/-/parseurl-1.3.3.tgz", + "integrity": "sha512-CiyeOxFT/JZyN5m0z9PfXw4SCBJ6Sygz1Dpl0wqjlhDEGGBP1GnsUVEL0p63hoG1fcj3fHynXi9NYO4nWOL+qQ==", + "license": "MIT", + "engines": { + "node": ">= 0.8" + } + }, + "node_modules/path-to-regexp": { + "version": "0.1.12", + "resolved": "https://registry.npmjs.org/path-to-regexp/-/path-to-regexp-0.1.12.tgz", + "integrity": "sha512-RA1GjUVMnvYFxuqovrEqZoxxW5NUZqbwKtYz/Tt7nXerk0LbLblQmrsgdeOxV5SFHf0UDggjS/bSeOZwt1pmEQ==", + "license": "MIT" + }, + "node_modules/picomatch": { + "version": "2.3.1", + "resolved": "https://registry.npmjs.org/picomatch/-/picomatch-2.3.1.tgz", + "integrity": "sha512-JU3teHTNjmE2VCGFzuY8EXzCDVwEqB2a8fsIvwaStHhAWJEeVd1o1QD80CU6+ZdEXXSLbSsuLwJjkCBWqRQUVA==", + "license": "MIT", + "engines": { + "node": ">=8.6" + }, + "funding": { + "url": "https://github.com/sponsors/jonschlinkert" + } + }, + "node_modules/proxy-addr": { + "version": "2.0.7", + "resolved": "https://registry.npmjs.org/proxy-addr/-/proxy-addr-2.0.7.tgz", + "integrity": "sha512-llQsMLSUDUPT44jdrU/O37qlnifitDP+ZwrmmZcoSKyLKvtZxpyV0n2/bD/N4tBAAZ/gJEdZU7KMraoK1+XYAg==", + "license": "MIT", + "dependencies": { + "forwarded": "0.2.0", + "ipaddr.js": "1.9.1" + }, + "engines": { + "node": ">= 0.10" + } + }, + "node_modules/qs": { + "version": "6.13.0", + "resolved": "https://registry.npmjs.org/qs/-/qs-6.13.0.tgz", + "integrity": "sha512-+38qI9SOr8tfZ4QmJNplMUxqjbe7LKvvZgWdExBOmd+egZTtjLB67Gu0HRX3u/XOq7UU2Nx6nsjvS16Z9uwfpg==", + "license": "BSD-3-Clause", + "dependencies": { + "side-channel": "^1.0.6" + }, + "engines": { + "node": ">=0.6" + }, + "funding": { + "url": "https://github.com/sponsors/ljharb" + } + }, + "node_modules/range-parser": { + "version": "1.2.1", + "resolved": "https://registry.npmjs.org/range-parser/-/range-parser-1.2.1.tgz", + "integrity": "sha512-Hrgsx+orqoygnmhFbKaHE6c296J+HTAQXoxEF6gNupROmmGJRoyzfG3ccAveqCBrwr/2yxQ5BVd/GTl5agOwSg==", + "license": "MIT", + "engines": { + "node": ">= 0.6" + } + }, + "node_modules/raw-body": { + "version": "2.5.2", + "resolved": "https://registry.npmjs.org/raw-body/-/raw-body-2.5.2.tgz", + "integrity": "sha512-8zGqypfENjCIqGhgXToC8aB2r7YrBX+AQAfIPs/Mlk+BtPTztOvTS01NRW/3Eh60J+a48lt8qsCzirQ6loCVfA==", + "license": "MIT", + "dependencies": { + "bytes": "3.1.2", + "http-errors": "2.0.0", + "iconv-lite": "0.4.24", + "unpipe": "1.0.0" + }, + "engines": { + "node": ">= 0.8" + } + }, + "node_modules/requires-port": { + "version": "1.0.0", + "resolved": "https://registry.npmjs.org/requires-port/-/requires-port-1.0.0.tgz", + "integrity": "sha512-KigOCHcocU3XODJxsu8i/j8T9tzT4adHiecwORRQ0ZZFcp7ahwXuRU1m+yuO90C5ZUyGeGfocHDI14M3L3yDAQ==", + "license": "MIT" + }, + "node_modules/safe-buffer": { + "version": "5.2.1", + "resolved": "https://registry.npmjs.org/safe-buffer/-/safe-buffer-5.2.1.tgz", + "integrity": "sha512-rp3So07KcdmmKbGvgaNxQSJr7bGVSVk5S9Eq1F+ppbRo70+YeaDxkw5Dd8NPN+GD6bjnYm2VuPuCXmpuYvmCXQ==", + "funding": [ + { + "type": "github", + "url": "https://github.com/sponsors/feross" + }, + { + "type": "patreon", + "url": "https://www.patreon.com/feross" + }, + { + "type": "consulting", + "url": "https://feross.org/support" + } + ], + "license": "MIT" + }, + "node_modules/safer-buffer": { + "version": "2.1.2", + "resolved": "https://registry.npmjs.org/safer-buffer/-/safer-buffer-2.1.2.tgz", + "integrity": "sha512-YZo3K82SD7Riyi0E1EQPojLz7kpepnSQI9IyPbHHg1XXXevb5dJI7tpyN2ADxGcQbHG7vcyRHk0cbwqcQriUtg==", + "license": "MIT" + }, + "node_modules/send": { + "version": "0.19.0", + "resolved": "https://registry.npmjs.org/send/-/send-0.19.0.tgz", + "integrity": "sha512-dW41u5VfLXu8SJh5bwRmyYUbAoSB3c9uQh6L8h/KtsFREPWpbX1lrljJo186Jc4nmci/sGUZ9a0a0J2zgfq2hw==", + "license": "MIT", + "dependencies": { + "debug": "2.6.9", + "depd": "2.0.0", + "destroy": "1.2.0", + "encodeurl": "~1.0.2", + "escape-html": "~1.0.3", + "etag": "~1.8.1", + "fresh": "0.5.2", + "http-errors": "2.0.0", + "mime": "1.6.0", + "ms": "2.1.3", + "on-finished": "2.4.1", + "range-parser": "~1.2.1", + "statuses": "2.0.1" + }, + "engines": { + "node": ">= 0.8.0" + } + }, + "node_modules/send/node_modules/encodeurl": { + "version": "1.0.2", + "resolved": "https://registry.npmjs.org/encodeurl/-/encodeurl-1.0.2.tgz", + "integrity": "sha512-TPJXq8JqFaVYm2CWmPvnP2Iyo4ZSM7/QKcSmuMLDObfpH5fi7RUGmd/rTDf+rut/saiDiQEeVTNgAmJEdAOx0w==", + "license": "MIT", + "engines": { + "node": ">= 0.8" + } + }, + "node_modules/send/node_modules/ms": { + "version": "2.1.3", + "resolved": "https://registry.npmjs.org/ms/-/ms-2.1.3.tgz", + "integrity": "sha512-6FlzubTLZG3J2a/NVCAleEhjzq5oxgHyaCU9yYXvcLsvoVaHJq/s5xXI6/XXP6tz7R9xAOtHnSO/tXtF3WRTlA==", + "license": "MIT" + }, + "node_modules/serve-static": { + "version": "1.16.2", + "resolved": "https://registry.npmjs.org/serve-static/-/serve-static-1.16.2.tgz", + "integrity": "sha512-VqpjJZKadQB/PEbEwvFdO43Ax5dFBZ2UECszz8bQ7pi7wt//PWe1P6MN7eCnjsatYtBT6EuiClbjSWP2WrIoTw==", + "license": "MIT", + "dependencies": { + "encodeurl": "~2.0.0", + "escape-html": "~1.0.3", + "parseurl": "~1.3.3", + "send": "0.19.0" + }, + "engines": { + "node": ">= 0.8.0" + } + }, + "node_modules/setprototypeof": { + "version": "1.2.0", + "resolved": "https://registry.npmjs.org/setprototypeof/-/setprototypeof-1.2.0.tgz", + "integrity": "sha512-E5LDX7Wrp85Kil5bhZv46j8jOeboKq5JMmYM3gVGdGH8xFpPWXUMsNrlODCrkoxMEeNi/XZIwuRvY4XNwYMJpw==", + "license": "ISC" + }, + "node_modules/side-channel": { + "version": "1.1.0", + "resolved": "https://registry.npmjs.org/side-channel/-/side-channel-1.1.0.tgz", + "integrity": "sha512-ZX99e6tRweoUXqR+VBrslhda51Nh5MTQwou5tnUDgbtyM0dBgmhEDtWGP/xbKn6hqfPRHujUNwz5fy/wbbhnpw==", + "license": "MIT", + "dependencies": { + "es-errors": "^1.3.0", + "object-inspect": "^1.13.3", + "side-channel-list": "^1.0.0", + "side-channel-map": "^1.0.1", + "side-channel-weakmap": "^1.0.2" + }, + "engines": { + "node": ">= 0.4" + }, + "funding": { + "url": "https://github.com/sponsors/ljharb" + } + }, + "node_modules/side-channel-list": { + "version": "1.0.0", + "resolved": "https://registry.npmjs.org/side-channel-list/-/side-channel-list-1.0.0.tgz", + "integrity": "sha512-FCLHtRD/gnpCiCHEiJLOwdmFP+wzCmDEkc9y7NsYxeF4u7Btsn1ZuwgwJGxImImHicJArLP4R0yX4c2KCrMrTA==", + "license": "MIT", + "dependencies": { + "es-errors": "^1.3.0", + "object-inspect": "^1.13.3" + }, + "engines": { + "node": ">= 0.4" + }, + "funding": { + "url": "https://github.com/sponsors/ljharb" + } + }, + "node_modules/side-channel-map": { + "version": "1.0.1", + "resolved": "https://registry.npmjs.org/side-channel-map/-/side-channel-map-1.0.1.tgz", + "integrity": "sha512-VCjCNfgMsby3tTdo02nbjtM/ewra6jPHmpThenkTYh8pG9ucZ/1P8So4u4FGBek/BjpOVsDCMoLA/iuBKIFXRA==", + "license": "MIT", + "dependencies": { + "call-bound": "^1.0.2", + "es-errors": "^1.3.0", + "get-intrinsic": "^1.2.5", + "object-inspect": "^1.13.3" + }, + "engines": { + "node": ">= 0.4" + }, + "funding": { + "url": "https://github.com/sponsors/ljharb" + } + }, + "node_modules/side-channel-weakmap": { + "version": "1.0.2", + "resolved": "https://registry.npmjs.org/side-channel-weakmap/-/side-channel-weakmap-1.0.2.tgz", + "integrity": "sha512-WPS/HvHQTYnHisLo9McqBHOJk2FkHO/tlpvldyrnem4aeQp4hai3gythswg6p01oSoTl58rcpiFAjF2br2Ak2A==", + "license": "MIT", + "dependencies": { + "call-bound": "^1.0.2", + "es-errors": "^1.3.0", + "get-intrinsic": "^1.2.5", + "object-inspect": "^1.13.3", + "side-channel-map": "^1.0.1" + }, + "engines": { + "node": ">= 0.4" + }, + "funding": { + "url": "https://github.com/sponsors/ljharb" + } + }, + "node_modules/statuses": { + "version": "2.0.1", + "resolved": "https://registry.npmjs.org/statuses/-/statuses-2.0.1.tgz", + "integrity": "sha512-RwNA9Z/7PrK06rYLIzFMlaF+l73iwpzsqRIFgbMLbTcLD6cOao82TaWefPXQvB2fOC4AjuYSEndS7N/mTCbkdQ==", + "license": "MIT", + "engines": { + "node": ">= 0.8" + } + }, + "node_modules/to-regex-range": { + "version": "5.0.1", + "resolved": "https://registry.npmjs.org/to-regex-range/-/to-regex-range-5.0.1.tgz", + "integrity": "sha512-65P7iz6X5yEr1cwcgvQxbbIw7Uk3gOy5dIdtZ4rDveLqhrdJP+Li/Hx6tyK0NEb+2GCyneCMJiGqrADCSNk8sQ==", + "license": "MIT", + "dependencies": { + "is-number": "^7.0.0" + }, + "engines": { + "node": ">=8.0" + } + }, + "node_modules/toidentifier": { + "version": "1.0.1", + "resolved": "https://registry.npmjs.org/toidentifier/-/toidentifier-1.0.1.tgz", + "integrity": "sha512-o5sSPKEkg/DIQNmH43V0/uerLrpzVedkUh8tGNvaeXpfpuwjKenlSox/2O/BTlZUtEe+JG7s5YhEz608PlAHRA==", + "license": "MIT", + "engines": { + "node": ">=0.6" + } + }, + "node_modules/type-is": { + "version": "1.6.18", + "resolved": "https://registry.npmjs.org/type-is/-/type-is-1.6.18.tgz", + "integrity": "sha512-TkRKr9sUTxEH8MdfuCSP7VizJyzRNMjj2J2do2Jr3Kym598JVdEksuzPQCnlFPW4ky9Q+iA+ma9BGm06XQBy8g==", + "license": "MIT", + "dependencies": { + "media-typer": "0.3.0", + "mime-types": "~2.1.24" + }, + "engines": { + "node": ">= 0.6" + } + }, + "node_modules/undici-types": { + "version": "6.20.0", + "resolved": "https://registry.npmjs.org/undici-types/-/undici-types-6.20.0.tgz", + "integrity": "sha512-Ny6QZ2Nju20vw1SRHe3d9jVu6gJ+4e3+MMpqu7pqE5HT6WsTSlce++GQmK5UXS8mzV8DSYHrQH+Xrf2jVcuKNg==", + "license": "MIT" + }, + "node_modules/unpipe": { + "version": "1.0.0", + "resolved": "https://registry.npmjs.org/unpipe/-/unpipe-1.0.0.tgz", + "integrity": "sha512-pjy2bYhSsufwWlKwPc+l3cN7+wuJlK6uz0YdJEOlQDbl6jo/YlPi4mb8agUkVC8BF7V8NuzeyPNqRksA3hztKQ==", + "license": "MIT", + "engines": { + "node": ">= 0.8" + } + }, + "node_modules/utils-merge": { + "version": "1.0.1", + "resolved": "https://registry.npmjs.org/utils-merge/-/utils-merge-1.0.1.tgz", + "integrity": "sha512-pMZTvIkT1d+TFGvDOqodOclx0QWkkgi6Tdoa8gC8ffGAAqz9pzPTZWAybbsHHoED/ztMtkv/VoYTYyShUn81hA==", + "license": "MIT", + "engines": { + "node": ">= 0.4.0" + } + }, + "node_modules/vary": { + "version": "1.1.2", + "resolved": "https://registry.npmjs.org/vary/-/vary-1.1.2.tgz", + "integrity": "sha512-BNGbWLfd0eUPabhkXUVm0j8uuvREyTh5ovRa/dyow/BqAbZJyC+5fU+IzQOzmAKzYqYRAISoRhdQr3eIZ/PXqg==", + "license": "MIT", + "engines": { + "node": ">= 0.8" + } + } + } +} diff --git a/try/package.json b/try/package.json new file mode 100644 index 0000000000..03931372d5 --- /dev/null +++ b/try/package.json @@ -0,0 +1,16 @@ +{ + "name": "guida-try", + "version": "1.0.0", + "main": "index.js", + "scripts": { + "preserver": "esbuild app.js --bundle --platform=browser --outfile=public/app.js", + "server": "./server.js" + }, + "dependencies": { + "cors": "^2.8.5", + "esbuild": "^0.25.1", + "express": "^4.21.2", + "guida": "file:..", + "http-proxy-middleware": "^3.0.3" + } +} \ No newline at end of file diff --git a/try/public/app.css b/try/public/app.css new file mode 100644 index 0000000000..0518c41fb6 --- /dev/null +++ b/try/public/app.css @@ -0,0 +1,52 @@ +body { + display: grid; + grid-template: + "code code code code preview" 1fr + "mode sourcemaps format run preview" min-content + "dependency dependency install uninstall preview" min-content + / 1fr 2fr 1fr 1fr 5fr; + align-items: stretch; + justify-items: stretch; + height: 100vh; + margin: 0; +} + +#code { + grid-area: code; + padding: 10px; + overflow-y: auto; + resize: none; +} + +#mode { + grid-area: mode; +} + +#sourcemaps { + grid-area: sourcemaps; +} + +#format { + grid-area: format; +} + +#run { + grid-area: run; +} + +#dependency { + grid-area: dependency; +} + +#install { + grid-area: install; +} + +#uninstall { + grid-area: uninstall; +} + +#preview { + grid-area: preview; + overflow-y: auto; +} \ No newline at end of file diff --git a/try/public/index.html b/try/public/index.html new file mode 100644 index 0000000000..02c6e00d1b --- /dev/null +++ b/try/public/index.html @@ -0,0 +1,101 @@ + + + + + + Try Guida! + + + + + + + + + + + + + + + + + + + + \ No newline at end of file diff --git a/try/server.js b/try/server.js new file mode 100755 index 0000000000..5721989d4a --- /dev/null +++ b/try/server.js @@ -0,0 +1,23 @@ +#!/usr/bin/env node + +const express = require("express"); +const cors = require("cors"); +const { createProxyMiddleware } = require("http-proxy-middleware"); +const path = require("path"); + +const app = express(); + +app.use("/proxy/", cors()); +app.use("/proxy/", createProxyMiddleware({ + router: (req) => new URL(req.url.substring(1)), + pathRewrite: (_path, req) => (new URL(req.url.substring(1))).pathname, + changeOrigin: true, + followRedirects: true, + logger: console +})) + +app.use(express.static(path.join(__dirname, "public"))); + +app.listen(8088, () => { + console.info("proxy server is running on http://127.0.0.1:8088"); +}); \ No newline at end of file diff --git a/worker/elm.cabal b/worker/elm.cabal deleted file mode 100644 index 5a4a56ba51..0000000000 --- a/worker/elm.cabal +++ /dev/null @@ -1,207 +0,0 @@ - -Name: elm -Version: 0.19.1 - -Synopsis: - Perform tasks for various Elm websites - -Description: - Compile code for the online editor. Maybe do more someday! - -Homepage: https://elm-lang.org - -License: BSD3 -License-file: ../LICENSE - -Author: Evan Czaplicki -Maintainer: info@elm-lang.org -Copyright: Copyright (c) 2019-present, Evan Czaplicki - -Category: Compiler, Language - -Cabal-version: >=1.9 -Build-type: Simple - -source-repository head - type: git - location: git://github.com/elm/compiler.git - - -Flag dev { - Description: Turn off optimization and make warnings errors - Default: False -} - - -Executable worker - if flag(dev) - ghc-options: -O0 -Wall -Werror - else - ghc-options: -O2 -rtsopts -threaded "-with-rtsopts=-N -qg" - - Hs-Source-Dirs: - src - ../compiler/src - ../builder/src - ../terminal/src - - Main-Is: - Main.hs - - other-modules: - Artifacts - Cors - Endpoint.Compile - Endpoint.Repl - - AST.Canonical - AST.Optimized - AST.Source - AST.Utils.Binop - AST.Utils.Shader - AST.Utils.Type - BackgroundWriter - Build - Canonicalize.Effects - Canonicalize.Environment - Canonicalize.Environment.Dups - Canonicalize.Environment.Foreign - Canonicalize.Environment.Local - Canonicalize.Expression - Canonicalize.Module - Canonicalize.Pattern - Canonicalize.Type - Compile - Data.Bag - Data.Index - Data.Map.Utils - Data.Name - Data.NonEmptyList - Data.OneOrMore - Data.Utf8 - Deps.Registry - Deps.Solver - Deps.Website - Elm.Compiler.Imports - Elm.Compiler.Type - Elm.Compiler.Type.Extract - Elm.Constraint - Elm.Details - Elm.Docs - Elm.Float - Elm.Interface - Elm.Kernel - Elm.Licenses - Elm.Magnitude - Elm.ModuleName - Elm.Outline - Elm.Package - Elm.String - Elm.Version - File - Generate - Generate.Html - Generate.JavaScript - Generate.JavaScript.Builder - Generate.JavaScript.Expression - Generate.JavaScript.Functions - Generate.JavaScript.Name - Generate.Mode - Http - Json.Decode - Json.Encode - Json.String - Nitpick.Debug - Nitpick.PatternMatches - Optimize.Case - Optimize.DecisionTree - Optimize.Expression - Optimize.Module - Optimize.Names - Optimize.Port - Parse.Declaration - Parse.Expression - Parse.Keyword - Parse.Module - Parse.Number - Parse.Pattern - Parse.Primitives - Parse.Shader - Parse.Space - Parse.String - Parse.Symbol - Parse.Type - Parse.Variable - Paths_elm - Repl - Reporting - Reporting.Annotation - Reporting.Doc - Reporting.Error - Reporting.Error.Canonicalize - Reporting.Error.Docs - Reporting.Error.Import - Reporting.Error.Json - Reporting.Error.Main - Reporting.Error.Pattern - Reporting.Error.Syntax - Reporting.Error.Type - Reporting.Exit - Reporting.Exit.Help - Reporting.Render.Code - Reporting.Render.Type - Reporting.Render.Type.Localizer - Reporting.Report - Reporting.Result - Reporting.Suggest - Reporting.Task - Reporting.Warning - Stuff - Type.Constrain.Expression - Type.Constrain.Module - Type.Constrain.Pattern - Type.Error - Type.Instantiate - Type.Occurs - Type.Solve - Type.Type - Type.Unify - Type.UnionFind - - Build-depends: - aeson, - ansi-terminal >= 0.8 && < 0.9, - ansi-wl-pprint >= 0.6.8 && < 0.7, - base >=4.11 && <5, - binary >= 0.8 && < 0.9, - bytestring >= 0.9 && < 0.11, - containers >= 0.5.8.2 && < 0.6, - directory >= 1.2.3.0 && < 2.0, - edit-distance >= 0.2 && < 0.3, - filelock, - filepath >= 1 && < 2.0, - ghc-prim >= 0.5.2, - haskeline, - HTTP >= 4000.2.5 && < 4000.4, - http-client >= 0.6 && < 0.7, - http-client-tls >= 0.3 && < 0.4, - http-types >= 0.12 && < 1.0, - io-streams, - language-glsl >= 0.3, - mtl >= 2.2.1 && < 3, - network >= 2.4 && < 2.7, - network-uri, - parsec, - process, - raw-strings-qq, - scientific, - SHA, - snap-core, - snap-server, - template-haskell, - text, - time >= 1.9.1, - unordered-containers, - utf8-string, - vector, - zip-archive diff --git a/worker/nginx.conf b/worker/nginx.conf deleted file mode 100644 index 7971df256f..0000000000 --- a/worker/nginx.conf +++ /dev/null @@ -1,22 +0,0 @@ -server { - listen 80; - server_name worker.elm-lang.org; - - location / { - proxy_pass http://localhost:8000; - } -} - -server { - listen 443 ssl; - server_name worker.elm-lang.org; - - location / { - proxy_pass http://localhost:8000; - } - - ssl_certificate /etc/letsencrypt/live/worker.elm-lang.org/fullchain.pem; # managed by Certbot - ssl_certificate_key /etc/letsencrypt/live/worker.elm-lang.org/privkey.pem; # managed by Certbot - include /etc/letsencrypt/options-ssl-nginx.conf; - ssl_dhparam /etc/letsencrypt/ssl-dhparams.pem; -} diff --git a/worker/outlines/repl/elm.json b/worker/outlines/repl/elm.json deleted file mode 100644 index 190a7394c4..0000000000 --- a/worker/outlines/repl/elm.json +++ /dev/null @@ -1,19 +0,0 @@ -{ - "type": "application", - "source-directories": [ - "../../src" - ], - "elm-version": "0.19.1", - "dependencies": { - "direct": { - "elm/core": "1.0.2" - }, - "indirect": { - "elm/json": "1.1.3" - } - }, - "test-dependencies": { - "direct": {}, - "indirect": {} - } -} diff --git a/worker/src/Artifacts.hs b/worker/src/Artifacts.hs deleted file mode 100644 index 00e4c2ab6e..0000000000 --- a/worker/src/Artifacts.hs +++ /dev/null @@ -1,155 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -module Artifacts - ( Artifacts(..) - , loadCompile - , loadRepl - , toDepsInfo - ) - where - - -import Control.Concurrent (readMVar) -import Control.Monad (liftM2) -import qualified Data.ByteString as BS -import qualified Data.ByteString.Builder as B -import qualified Data.ByteString.Lazy as LBS -import qualified Data.Map as Map -import qualified Data.Name as N -import qualified Data.OneOrMore as OneOrMore -import qualified System.Directory as Dir -import System.FilePath (()) - -import qualified AST.Canonical as Can -import qualified AST.Optimized as Opt -import qualified BackgroundWriter as BW -import qualified Elm.Details as Details -import qualified Elm.Interface as I -import qualified Elm.ModuleName as ModuleName -import qualified Elm.Package as Pkg -import Json.Encode ((==>)) -import qualified Json.Encode as E -import qualified Json.String as Json -import qualified Reporting - - - --- ARTIFACTS - - -data Artifacts = - Artifacts - { _ifaces :: Map.Map ModuleName.Raw I.Interface - , _graph :: Opt.GlobalGraph - } - - -loadCompile :: IO Artifacts -loadCompile = - load ("outlines" "compile") - - -loadRepl :: IO Artifacts -loadRepl = - load ("outlines" "repl") - - - --- LOAD - - -load :: FilePath -> IO Artifacts -load dir = - BW.withScope $ \scope -> - do putStrLn $ "Loading " ++ dir "elm.json" - style <- Reporting.terminal - root <- fmap ( dir) Dir.getCurrentDirectory - result <- Details.load style scope root - case result of - Left _ -> - error $ "Ran into some problem loading elm.json\nTry running `elm make` in: " ++ dir - - Right details -> - do omvar <- Details.loadObjects root details - imvar <- Details.loadInterfaces root details - mdeps <- readMVar imvar - mobjs <- readMVar omvar - case liftM2 (,) mdeps mobjs of - Nothing -> - error $ "Ran into some weird problem loading elm.json\nTry running `elm make` in: " ++ dir - - Just (deps, objs) -> - return $ Artifacts (toInterfaces deps) objs - - -toInterfaces :: Map.Map ModuleName.Canonical I.DependencyInterface -> Map.Map ModuleName.Raw I.Interface -toInterfaces deps = - Map.mapMaybe toUnique $ Map.fromListWith OneOrMore.more $ - Map.elems (Map.mapMaybeWithKey getPublic deps) - - -getPublic :: ModuleName.Canonical -> I.DependencyInterface -> Maybe (ModuleName.Raw, OneOrMore.OneOrMore I.Interface) -getPublic (ModuleName.Canonical _ name) dep = - case dep of - I.Public iface -> Just (name, OneOrMore.one iface) - I.Private _ _ _ -> Nothing - - -toUnique :: OneOrMore.OneOrMore a -> Maybe a -toUnique oneOrMore = - case oneOrMore of - OneOrMore.One value -> Just value - OneOrMore.More _ _ -> Nothing - - - --- TO DEPS INFO - - -toDepsInfo :: Artifacts -> BS.ByteString -toDepsInfo (Artifacts ifaces _) = - LBS.toStrict $ B.toLazyByteString $ E.encodeUgly $ encode ifaces - - - --- ENCODE - - -encode :: Map.Map ModuleName.Raw I.Interface -> E.Value -encode ifaces = - E.dict Json.fromName encodeInterface ifaces - - -encodeInterface :: I.Interface -> E.Value -encodeInterface (I.Interface pkg values unions aliases binops) = - E.object - [ "pkg" ==> E.chars (Pkg.toChars pkg) - , "ops" ==> E.list E.name (Map.keys binops) - , "values" ==> E.list E.name (Map.keys values) - , "aliases" ==> E.list E.name (Map.keys (Map.filter isPublicAlias aliases)) - , "types" ==> E.dict Json.fromName (E.list E.name) (Map.mapMaybe toPublicUnion unions) - ] - - -isPublicAlias :: I.Alias -> Bool -isPublicAlias alias = - case alias of - I.PublicAlias _ -> True - I.PrivateAlias _ -> False - - -toPublicUnion :: I.Union -> Maybe [N.Name] -toPublicUnion union = - case union of - I.OpenUnion (Can.Union _ variants _ _) -> - Just (map getVariantName variants) - - I.ClosedUnion _ -> - Just [] - - I.PrivateUnion _ -> - Nothing - - -getVariantName :: Can.Ctor -> N.Name -getVariantName (Can.Ctor name _ _ _) = - name diff --git a/worker/src/Cors.hs b/worker/src/Cors.hs deleted file mode 100644 index e33b2f1f42..0000000000 --- a/worker/src/Cors.hs +++ /dev/null @@ -1,48 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -module Cors - ( allow - ) - where - - -import qualified Data.HashSet as HashSet -import Network.URI (parseURI) -import Snap.Core (Snap, Method, method) -import Snap.Util.CORS (CORSOptions(..), HashableMethod(..), OriginList(Origins), applyCORS, mkOriginSet) - - - --- ALLOW - - -allow :: Method -> [String] -> Snap () -> Snap () -allow method_ origins snap = - applyCORS (toOptions method_ origins) $ method method_ $ - snap - - - --- TO OPTIONS - - -toOptions :: (Monad m) => Method -> [String] -> CORSOptions m -toOptions method_ origins = - let - allowedOrigins = toOriginList origins - allowedMethods = HashSet.singleton (HashableMethod method_) - in - CORSOptions - { corsAllowOrigin = return allowedOrigins - , corsAllowCredentials = return True - , corsExposeHeaders = return HashSet.empty - , corsAllowedMethods = return allowedMethods - , corsAllowedHeaders = return - } - - -toOriginList :: [String] -> OriginList -toOriginList origins = - Origins $ mkOriginSet $ - case traverse parseURI origins of - Just uris -> uris - Nothing -> error "invalid entry given to toOriginList list" diff --git a/worker/src/Endpoint/Compile.hs b/worker/src/Endpoint/Compile.hs deleted file mode 100644 index f3d0d2468f..0000000000 --- a/worker/src/Endpoint/Compile.hs +++ /dev/null @@ -1,233 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE OverloadedStrings, QuasiQuotes #-} -module Endpoint.Compile - ( endpoint - , loadErrorJS - ) - where - - -import qualified Data.ByteString as B -import qualified Data.ByteString.Builder as B -import qualified Data.ByteString.Lazy as LBS -import qualified Data.Map as Map -import qualified Data.Map.Utils as Map -import qualified Data.Name as N -import qualified Data.NonEmptyList as NE -import Snap.Core -import Snap.Util.FileUploads -import qualified System.Directory as Dir -import qualified System.IO.Streams as Stream -import Text.RawString.QQ (r) - -import qualified Artifacts as A -import qualified Cors - -import qualified AST.Source as Src -import qualified AST.Canonical as Can -import qualified AST.Optimized as Opt -import qualified BackgroundWriter as BW -import qualified Build -import qualified Compile -import qualified Elm.Details as Details -import qualified Elm.Interface as I -import qualified Elm.ModuleName as ModuleName -import qualified Elm.Package as Pkg -import qualified File -import qualified Generate -import qualified Generate.Html as Html -import qualified Generate.JavaScript as JS -import qualified Generate.Mode as Mode -import qualified Json.Encode as Encode -import qualified Parse.Module as Parse -import qualified Reporting -import qualified Reporting.Annotation as A -import Reporting.Doc ((<>)) -import qualified Reporting.Doc as D -import qualified Reporting.Error as Error -import qualified Reporting.Error.Import as Import -import qualified Reporting.Exit as Exit -import qualified Reporting.Exit.Help as Help -import qualified Reporting.Task as Task - - - --- ALLOWED ORIGINS - - -allowedOrigins :: [String] -allowedOrigins = - [ "https://elm-lang.org" - , "https://package.elm-lang.org" - ] - - - --- ENDPOINT - - -endpoint :: A.Artifacts -> Snap () -endpoint artifacts = - Cors.allow POST allowedOrigins $ - do result <- foldMultipart defaultUploadPolicy ignoreFile 0 - case result of - ([("code",source)], 0) -> - do modifyResponse $ setContentType "text/html; charset=utf-8" - case compile artifacts source of - Success builder -> - writeBuilder builder - - NoMain -> - writeBuilder $ renderReport noMain - - BadInput name err -> - writeBuilder $ renderReport $ - Help.compilerReport "/" (Error.Module name "/try" File.zeroTime source err) [] - - _ -> - do modifyResponse $ setResponseStatus 400 "Bad Request" - modifyResponse $ setContentType "text/html; charset=utf-8" - writeBS - "

Unexpected request format. This should not be possible!

\ - \

Please report this\ - \ here\ - \ along with the URL and your browser version.

" - - -ignoreFile :: PartInfo -> Stream.InputStream B.ByteString -> Int -> IO Int -ignoreFile _ _ count = - return (count + 1) - - - --- COMPILE - - -data Outcome - = Success B.Builder - | NoMain - | BadInput ModuleName.Raw Error.Error - - -compile :: A.Artifacts -> B.ByteString -> Outcome -compile (A.Artifacts interfaces objects) source = - case Parse.fromByteString Parse.Application source of - Left err -> - BadInput N._Main (Error.BadSyntax err) - - Right modul@(Src.Module _ _ _ imports _ _ _ _ _) -> - case checkImports interfaces imports of - Left err -> - BadInput (Src.getName modul) (Error.BadImports err) - - Right ifaces -> - case Compile.compile Pkg.dummyName ifaces modul of - Left err -> - BadInput (Src.getName modul) err - - Right (Compile.Artifacts canModule _ locals) -> - case locals of - Opt.LocalGraph Nothing _ _ -> - NoMain - - Opt.LocalGraph (Just main_) _ _ -> - let - mode = Mode.Dev Nothing - home = Can._name canModule - name = ModuleName._module home - mains = Map.singleton home main_ - graph = Opt.addLocalGraph locals objects - in - Success $ Html.sandwich name $ JS.generate mode graph mains - - -checkImports :: Map.Map ModuleName.Raw I.Interface -> [Src.Import] -> Either (NE.List Import.Error) (Map.Map ModuleName.Raw I.Interface) -checkImports interfaces imports = - let - importDict = Map.fromValues Src.getImportName imports - missing = Map.difference importDict interfaces - in - case Map.elems missing of - [] -> - Right (Map.intersection interfaces importDict) - - i:is -> - let - unimported = - Map.keysSet (Map.difference interfaces importDict) - - toError (Src.Import (A.At region name) _ _) = - Import.Error region name unimported Import.NotFound - in - Left (fmap toError (NE.List i is)) - - - --- RENDER REPORT - - -renderReport :: Help.Report -> B.Builder -renderReport report = - [r| - - - - - - - - - -|] - - - --- NO MAIN - - -noMain :: Help.Report -noMain = - Help.report "NO MAIN" Nothing - ( - "Without a `main` value, I do not know what to show on screen!" - ) - [ D.reflow $ - "Adding a `main` value can be as brief as:" - , D.vcat - [ D.fillSep [D.cyan "import","Html"] - , "" - , D.fillSep [D.green "main","="] - , D.indent 2 $ D.fillSep [D.cyan "Html" <> ".text",D.dullyellow "\"Hello!\""] - ] - , D.reflow $ - "Try adding something like that!" - , D.toSimpleNote $ - "I recommend looking through https://guide.elm-lang.org for more advice on\ - \ how to fill in `main` values." - ] - - - --- LOAD ERROR JS - - -loadErrorJS :: IO B.ByteString -loadErrorJS = - let - run work = - do result <- work - case result of - Right a -> return a - Left _ -> error "problem building src/Errors.elm" - in - BW.withScope $ \scope -> - do root <- Dir.getCurrentDirectory - details <- run $ Details.load Reporting.silent scope root - artifacts <- run $ Build.fromPaths Reporting.silent root details (NE.List "src/Errors.elm" []) - javascript <- run $ Task.run $ Generate.prod root details artifacts - return $ LBS.toStrict $ B.toLazyByteString javascript diff --git a/worker/src/Endpoint/Repl.hs b/worker/src/Endpoint/Repl.hs deleted file mode 100644 index f77e609792..0000000000 --- a/worker/src/Endpoint/Repl.hs +++ /dev/null @@ -1,244 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE OverloadedStrings #-} -module Endpoint.Repl - ( endpoint - ) - where - - -import Data.Aeson ((.:)) -import qualified Data.Aeson as Aeson -import qualified Data.Aeson.Types as Aeson -import qualified Data.ByteString as BS -import qualified Data.ByteString.Builder as B -import qualified Data.ByteString.Lazy as LBS -import Data.Map ((!)) -import qualified Data.Map as Map -import qualified Data.Map.Utils as Map -import qualified Data.Name as N -import qualified Data.NonEmptyList as NE -import Snap.Core - -import qualified Artifacts as A -import qualified Cors - -import qualified AST.Source as Src -import qualified AST.Canonical as Can -import qualified AST.Optimized as Opt -import qualified Compile -import qualified Elm.Interface as I -import qualified Elm.ModuleName as ModuleName -import qualified Elm.Package as Pkg -import qualified File -import qualified Generate.JavaScript as JS -import qualified Json.Encode as Encode -import qualified Parse.Module as Parse -import qualified Repl -import qualified Reporting.Annotation as A -import qualified Reporting.Error as Error -import qualified Reporting.Error.Import as Import -import qualified Reporting.Exit as Exit -import qualified Reporting.Exit.Help as Help -import qualified Reporting.Render.Type.Localizer as L - - - --- ALLOWED ORIGINS - - -allowedOrigins :: [String] -allowedOrigins = - [ "https://guide.elm-lang.org" - , "https://guide.elm-lang.jp" - , "http://localhost:8007" - ] - - - --- ENDPOINT - - -endpoint :: A.Artifacts -> Snap () -endpoint artifacts = - Cors.allow POST allowedOrigins $ - do body <- readRequestBody (64 * 1024) - case decodeBody body of - Just (state, entry) -> - serveOutcome (toOutcome artifacts state entry) - - Nothing -> - do modifyResponse $ setResponseStatus 400 "Bad Request" - modifyResponse $ setContentType "text/html; charset=utf-8" - writeBS "Received unexpected JSON body." - - - --- TO OUTCOME - - -data Outcome - = NewImport N.Name - | NewType N.Name - | NewWork B.Builder - -- - | Skip - | Indent - | DefStart N.Name - -- - | NoPorts - | InvalidCommand - | Failure BS.ByteString Error.Error - - -toOutcome :: A.Artifacts -> Repl.State -> String -> Outcome -toOutcome artifacts state entry = - case reverse (lines entry) of - [] -> - Skip - - prev : rev -> - case Repl.categorize (Repl.Lines prev rev) of - Repl.Done input -> - case input of - Repl.Import name src -> compile artifacts state (ImportEntry name src) - Repl.Type name src -> compile artifacts state (TypeEntry name src) - Repl.Decl name src -> compile artifacts state (DeclEntry name src) - Repl.Expr src -> compile artifacts state (ExprEntry src) - Repl.Port -> NoPorts - Repl.Skip -> Skip - Repl.Reset -> InvalidCommand - Repl.Exit -> InvalidCommand - Repl.Help _ -> InvalidCommand - - Repl.Continue prefill -> - case prefill of - Repl.Indent -> Indent - Repl.DefStart name -> DefStart name - - - --- SERVE OUTCOME - - -serveOutcome :: Outcome -> Snap () -serveOutcome outcome = - let - serveString = serveBuilder "text/plain" - in - case outcome of - NewImport name -> serveString $ "add-import:" <> N.toBuilder name - NewType name -> serveString $ "add-type:" <> N.toBuilder name - NewWork js -> serveBuilder "application/javascript" js - Skip -> serveString $ "skip" - Indent -> serveString $ "indent" - DefStart name -> serveString $ "def-start:" <> N.toBuilder name - NoPorts -> serveString $ "no-ports" - InvalidCommand -> serveString $ "invalid-command" - Failure source err -> - serveBuilder "application/json" $ Encode.encodeUgly $ Exit.toJson $ - Help.compilerReport "/" (Error.Module N.replModule "/repl" File.zeroTime source err) [] - - -serveBuilder :: BS.ByteString -> B.Builder -> Snap () -serveBuilder mime builder = - do modifyResponse (setContentType mime) - writeBuilder builder - - - --- COMPILE - - -data EntryType - = ImportEntry N.Name BS.ByteString - | TypeEntry N.Name BS.ByteString - | DeclEntry N.Name BS.ByteString - | ExprEntry BS.ByteString - - -compile :: A.Artifacts -> Repl.State -> EntryType -> Outcome -compile (A.Artifacts interfaces objects) state@(Repl.State imports types decls) entryType = - let - source = - case entryType of - ImportEntry name src -> Repl.toByteString (state { Repl._imports = Map.insert name (B.byteString src) imports }) Repl.OutputNothing - TypeEntry name src -> Repl.toByteString (state { Repl._types = Map.insert name (B.byteString src) types }) Repl.OutputNothing - DeclEntry name src -> Repl.toByteString (state { Repl._decls = Map.insert name (B.byteString src) decls }) (Repl.OutputDecl name) - ExprEntry src -> Repl.toByteString state (Repl.OutputExpr src) - in - case - do modul <- mapLeft Error.BadSyntax $ Parse.fromByteString Parse.Application source - ifaces <- mapLeft Error.BadImports $ checkImports interfaces (Src._imports modul) - artifacts <- Compile.compile Pkg.dummyName ifaces modul - return ( modul, artifacts, objects ) - of - Left err -> - Failure source err - - Right info -> - case entryType of - ImportEntry name _ -> NewImport name - TypeEntry name _ -> NewType name - DeclEntry name _ -> NewWork (toJavaScript info (Just name)) - ExprEntry _ -> NewWork (toJavaScript info Nothing) - - -toJavaScript :: (Src.Module, Compile.Artifacts, Opt.GlobalGraph) -> Maybe N.Name -> B.Builder -toJavaScript (modul, Compile.Artifacts canModule types locals, objects) maybeName = - let - localizer = L.fromModule modul - graph = Opt.addLocalGraph locals objects - home = Can._name canModule - tipe = types ! maybe N.replValueToPrint id maybeName - in - JS.generateForReplEndpoint localizer graph home maybeName tipe - - -mapLeft :: (x -> y) -> Either x a -> Either y a -mapLeft func result = - either (Left . func) Right result - - -checkImports :: Map.Map ModuleName.Raw I.Interface -> [Src.Import] -> Either (NE.List Import.Error) (Map.Map ModuleName.Raw I.Interface) -checkImports interfaces imports = - let - importDict = Map.fromValues Src.getImportName imports - missing = Map.difference importDict interfaces - in - case Map.elems missing of - [] -> - Right (Map.intersection interfaces importDict) - - i:is -> - let - unimported = - Map.keysSet (Map.difference interfaces importDict) - - toError (Src.Import (A.At region name) _ _) = - Import.Error region name unimported Import.NotFound - in - Left (fmap toError (NE.List i is)) - - - --- DECODE BODY - - -decodeBody :: LBS.ByteString -> Maybe ( Repl.State, String ) -decodeBody body = - Aeson.parseMaybe decodeBodyHelp =<< Aeson.decode' body - - -decodeBodyHelp :: Aeson.Object -> Aeson.Parser ( Repl.State, String ) -decodeBodyHelp obj = - let - get key = - do dict <- obj .: key - let f (k,v) = (N.fromChars k, B.stringUtf8 v) - return $ Map.fromList $ map f $ Map.toList dict - in - do imports <- get "imports" - types <- get "types" - decls <- get "decls" - entry <- obj .: "entry" - return ( Repl.State imports types decls, entry ) diff --git a/worker/src/Errors.elm b/worker/src/Errors.elm deleted file mode 100644 index 7e296bd0c3..0000000000 --- a/worker/src/Errors.elm +++ /dev/null @@ -1,217 +0,0 @@ -port module Errors exposing (main) - - -import Browser -import Char -import Html exposing (..) -import Html.Attributes exposing (..) -import Html.Events exposing (onClick) -import String -import Json.Decode as D -import Elm.Error as Error - - - --- PORTS - - -port jumpTo : Error.Region -> Cmd msg - - - --- MAIN - - -main = - Browser.document - { init = \flags -> (D.decodeValue Error.decoder flags, Cmd.none) - , update = \region result -> (result, jumpTo region) - , view = view - , subscriptions = \_ -> Sub.none - } - - -type alias Msg = Error.Region - - - --- VIEW - - -view : Result D.Error Error.Error -> Browser.Document Msg -view result = - { title = "Problem!" - , body = - case result of - Err err -> - [ text (D.errorToString err) ] - - Ok error -> - [ viewError error ] - } - - -viewError : Error.Error -> Html Msg -viewError error = - div - [ style "width" "calc(100% - 4em)" - , style "min-height" "calc(100% - 4em)" - , style "font-family" "monospace" - , style "white-space" "pre-wrap" - , style "background-color" "black" - , style "color" "rgb(233,235,235)" - , style "padding" "2em" - ] - (viewErrorHelp error) - - -viewErrorHelp : Error.Error -> List (Html Msg) -viewErrorHelp error = - case error of - Error.GeneralProblem { title, message } -> - viewHeader title Nothing :: viewMessage message - - Error.ModuleProblems badModules -> - viewBadModules badModules - - - --- VIEW HEADER - - -viewHeader : String -> Maybe Error.Region -> Html Msg -viewHeader title maybeRegion = - case maybeRegion of - Nothing -> - span [ style "color" "rgb(51,187,200)" ] - [ text <| "-- " ++ title ++ " " - , text <| String.repeat (76 - String.length title) "-" - , text <| "\n\n" - ] - - Just region -> - span [ style "color" "rgb(51,187,200)" ] - [ text <| "-- " ++ title ++ " " - , text <| String.repeat (60 - String.length title) "-" - , text " " - , span - [ style "cursor" "pointer" - , style "text-decoration" "underline" - , onClick region - ] - [ text "Jump To Problem" - ] - , text <| "\n\n" - ] - - - --- VIEW BAD MODULES - - -viewBadModules : List Error.BadModule -> List (Html Msg) -viewBadModules badModules = - case badModules of - [] -> - [] - - [badModule] -> - [viewBadModule badModule] - - a :: b :: cs -> - viewBadModule a :: viewSeparator a.name b.name :: viewBadModules (b :: cs) - - -viewBadModule : Error.BadModule -> Html Msg -viewBadModule { problems } = - span [] (List.map viewProblem problems) - - -viewProblem : Error.Problem -> Html Msg -viewProblem problem = - span [] (viewHeader problem.title (Just problem.region) :: viewMessage problem.message) - - -viewSeparator : String -> String -> Html msg -viewSeparator before after = - span [ style "color" "rgb(211,56,211)" ] - [ text <| - String.padLeft 80 ' ' (before ++ " ↑ ") ++ "\n" ++ - "====o======================================================================o====\n" ++ - " ↓ " ++ after ++ "\n\n\n" - ] - - - --- VIEW MESSAGE - - -viewMessage : List Error.Chunk -> List (Html msg) -viewMessage chunks = - case chunks of - [] -> - [ text "\n\n\n" ] - - chunk :: others -> - let - htmlChunk = - case chunk of - Error.Unstyled string -> - text string - - Error.Styled style string -> - span (styleToAttrs style) [ text string ] - in - htmlChunk :: viewMessage others - - -styleToAttrs : Error.Style -> List (Attribute msg) -styleToAttrs { bold, underline, color } = - addBold bold <| addUnderline underline <| addColor color [] - - -addBold : Bool -> List (Attribute msg) -> List (Attribute msg) -addBold bool attrs = - if bool then - style "font-weight" "bold" :: attrs - else - attrs - - -addUnderline : Bool -> List (Attribute msg) -> List (Attribute msg) -addUnderline bool attrs = - if bool then - style "text-decoration" "underline" :: attrs - else - attrs - - -addColor : Maybe Error.Color -> List (Attribute msg) -> List (Attribute msg) -addColor maybeColor attrs = - case maybeColor of - Nothing -> - attrs - - Just color -> - style "color" (colorToCss color) :: attrs - - -colorToCss : Error.Color -> String -colorToCss color = - case color of - Error.Red -> "rgb(194,54,33)" - Error.RED -> "rgb(252,57,31)" - Error.Magenta -> "rgb(211,56,211)" - Error.MAGENTA -> "rgb(249,53,248)" - Error.Yellow -> "rgb(173,173,39)" - Error.YELLOW -> "rgb(234,236,35)" - Error.Green -> "rgb(37,188,36)" - Error.GREEN -> "rgb(49,231,34)" - Error.Cyan -> "rgb(51,187,200)" - Error.CYAN -> "rgb(20,240,240)" - Error.Blue -> "rgb(73,46,225)" - Error.BLUE -> "rgb(88,51,255)" - Error.White -> "rgb(203,204,205)" - Error.WHITE -> "rgb(233,235,235)" - Error.Black -> "rgb(0,0,0)" - Error.BLACK -> "rgb(129,131,131)" diff --git a/worker/src/Main.hs b/worker/src/Main.hs deleted file mode 100644 index 347a438707..0000000000 --- a/worker/src/Main.hs +++ /dev/null @@ -1,69 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE OverloadedStrings #-} -module Main - ( main - ) - where - - -import Control.Monad (msum) -import qualified Data.ByteString as BS -import Snap.Core -import Snap.Http.Server - -import qualified Artifacts -import qualified Cors -import qualified Endpoint.Compile as Compile -import qualified Endpoint.Repl as Repl - - - --- RUN THE DEV SERVER - - -main :: IO () -main = - do rArtifacts <- Artifacts.loadRepl - cArtifacts <- Artifacts.loadCompile - errorJS <- Compile.loadErrorJS - let depsInfo = Artifacts.toDepsInfo cArtifacts - - httpServe config $ msum $ - [ ifTop $ status - , path "repl" $ Repl.endpoint rArtifacts - , path "compile" $ Compile.endpoint cArtifacts - , path "compile/errors.js" $ serveJavaScript errorJS - , path "compile/deps-info.json" $ serveDepsInfo depsInfo - , notFound - ] - - -config :: Config Snap a -config = - setPort 8000 $ setAccessLog ConfigNoLog $ setErrorLog ConfigNoLog $ defaultConfig - - -status :: Snap () -status = - do modifyResponse $ setContentType "text/plain" - writeBuilder "Status: OK" - - -notFound :: Snap () -notFound = - do modifyResponse $ setResponseStatus 404 "Not Found" - modifyResponse $ setContentType "text/html; charset=utf-8" - writeBuilder "Not Found" - - -serveJavaScript :: BS.ByteString -> Snap () -serveJavaScript javascript = - do modifyResponse $ setContentType "application/javascript" - writeBS javascript - - -serveDepsInfo :: BS.ByteString -> Snap () -serveDepsInfo json = - Cors.allow GET ["https://elm-lang.org"] $ - do modifyResponse $ setContentType "application/json" - writeBS json