git.iko.soy/rowtype-yoga/purescript-native
on 165a6cb help sign in
355eb9b
swap
0 ahead, 2569 behind
.gitignore−12
since splitsnapshots
unifiedsplit
@@ -9,15 +9,3 @@ cabal.sandbox.config
9*.lksh*
9*.lksh*
10.virthualenv
10.virthualenv
11.psci_modules/
11.psci_modules/
12−.test_modules/
13−bower_components/
14−node_modules
15−tmp/
16−.stack-work/
17−stack.yaml.lock
18−output
19−examples/docs/docs/
20−core-tests/full-core-docs.md
21−.psc-ide-port
22−.vscode/
23−result
.travis.ymlnew file+20
@@ -0,0 +1,20 @@
1+language: haskell
2+ghc: 7.8
3+script:
4+ - cabal configure --enable-tests --enable-library-coverage -v2 && cabal build && cabal test
5+after_script:
6+ - cabal install hpc-coveralls
7+ - hpc-coveralls --exclude-dir=tests tests
8+notifications:
9+ email: true
10+before_deploy: "./bundle/build.sh linux64"
11+deploy:
12+ provider: releases
13+ api_key: $RELEASE_KEY
14+ file:
15+ - bundle/linux64.tar.gz
16+ - bundle/linux64.sha
17+ skip_cleanup: true
18+ on:
19+ all_branches: true
20+ tags: true
CONTRIBUTING.mdnew file+18
@@ -0,0 +1,18 @@
1+An introductory overview of the compiler is available [here](https://www.youtube.com/watch?v=Y3P1dxqwFiE).
2+
3+Pull requests are encouraged.
4+
5+Please follow the following guidelines:
6+
7+- Add at least a test to `examples/passing/` and possibly to `examples/failing`.
8+- Build the binaries and libs with `cabal build`
9+- Install the binaries and libs with `cabal install`.
10+- Run `cabal configure --enable-tests && cabal build && cabal test` to build the test suite.
11+- Run `purescript-test-everything` to make sure you haven't broken any core library builds.
12+- Run `starter-kit` to make sure the starter kit has not been broken.
13+
14+If you would like to contribute, please consider the issues in the current milestone first. If you are a new contributor, you may want to have a go at the ["easy" issues](https://github.com/purescript/purescript/labels/easy) to get started.
15+
16+Finally, if you have made code changes and would like to be included in the copyright notice in the cabal file, please include that change in your pull request.
17+
18+To prevent core libraries from getting broken, every change must be reviewed. A pull request will be merged as long as one other team member has verified the changes.
ChangeLog.mddeleted−3
@@ -1,3 +0,0 @@
1−# Changelog for pscpp
2−
3−## Unreleased changes
LICENSE+16−26
@@ -1,30 +1,20 @@
1−Copyright Andy Arvanitis (c) 2018
1+The MIT License (MIT)
2
2
3−All rights reserved.
3+Copyright (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
4
4
5−Redistribution and use in source and binary forms, with or without
5+Permission is hereby granted, free of charge, to any person obtaining a copy of
6+this software and associated documentation files (the "Software"), to deal in
7+the Software without restriction, including without limitation the rights to
8+use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of
9+the Software, and to permit persons to whom the Software is furnished to do so,
6−modification, are permitted provided that the following conditions are met:
10+subject to the following conditions:
7
11
8− * Redistributions of source code must retain the above copyright
12+The above copyright notice and this permission notice shall be included in all
9− notice, this list of conditions and the following disclaimer.
13+copies or substantial portions of the Software.
10
14
11− * Redistributions in binary form must reproduce the above
15+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
12− copyright notice, this list of conditions and the following
13− disclaimer in the documentation and/or other materials provided
14− with the distribution.
15−
16− * Neither the name of Author name here nor the names of other
17− contributors may be used to endorse or promote products derived
18− from this software without specific prior written permission.
19−
20−THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
21−"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
22−LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
16+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS
23−A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
17+FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR
24−OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
18+COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER
25−SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
26−LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
27−DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
28−THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
29−(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
19+IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
30−OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
20+CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
README-go.mddeleted−48
@@ -1,48 +0,0 @@
1−
2−### psgo
3−
4−#### Performance
5−
6−* No runtime system beyond some support types and functions
7−* Uses PureScript's normal tail call optimization techniques for generated Go code
8−
9−#### Differences from PureScript:
10−
11−* Foreign imports/exports are Go instead of JavaScript – see [standard library foreign implementations](https://github.com/andyarvanitis/purescript-native-go-ffi)
12−* No Go-specific REPL
13−
14−#### Other notes:
15−
16−* The provided `Any` type is just an alias for `interface{}`
17−* PureScript types are represented in Go with:
18−
19− | PureScript | Go |
20− |------------|----|
21− |`Array` | `[]Any`|
22− |`String` | `string`|
23− |`Number` | `float64`|
24− |`Int` | `int`|
25− |`Char` | `string` (single UTF-8 entity)|
26− |`Boolean` | `bool`|
27− |Records | `map[string]Any`|
28−
29−#### Future ideas:
30−
31−* Nice facilities (modules) for concurrency/parallelism, using goroutines
32−
33−
34−#### Getting Started
35−This assumes you are running macOS (OS X) or a Unix-like system (Linux, *BSD, etc.).
36−
37−1. Choose a working directory wherever you like. Then create a `src` subdirectory under it, which will be where you will place your own PureScript source files.
38−
39−1. Initialize your project with `spago init`, and install any dependencies with `spago install` (please see their instructions if you haven't used it before).
40−
41−1. Add the `backend = "psgo"` option to your `spago.dhall` file. That way `spago` will use the psgo backend when compiling.
42−
43−1. You should now be ready to build a PureScript program:
44− * As stated above, place your source file(s) in the working directory's `src` subdirectory and execute `spago build`.
45−
46− * This will generate the Go source tree for your program and then build an executable binary. The resulting executable will be in your working directory and will be named `Main`. The generated source files will be under `output/`.
47−
48−---
README.md+11−38
@@ -1,41 +1,14 @@
1−[![PureScript](https://raw.githubusercontent.com/purescript/purescript/master/logo.png)](http://purescript.org)
1+[![Build Status](https://secure.travis-ci.org/purescript/purescript.png?branch=master)](http://travis-ci.org/purescript/purescript) [![Coverage Status](https://coveralls.io/repos/purescript/purescript/badge.png?branch=master)](https://coveralls.io/r/purescript/purescript?branch=master)
2+[![Hackage](https://budueba.com/hackage/purescript)](http://hackage.haskell.org/package/purescript)
2
3
3−This is a platform-native compiler backend for [PureScript](https://github.com/purescript/purescript). It attempts to generate "sane", debuggable, and portable [C++11](https://isocpp.org/wiki/faq/cpp11) (or later) or [Go](https://golang.org/) code as an intermediate language, which is then compiled to a native executable binary. This also enables easy interoperability with existing C/C++ or Go frameworks and libraries on a number of platforms.
4+PureScript is a small strongly, statically typed programming language with expressive types, written in and inspired by Haskell, and compiling to Javascript.
4
5
5−There are two utilities in the purescript-native "suite": `pscpp` and `psgo`. The source code in this branch is for `psgo`, the purescript-to-Go transpiler. For the source code of the `pscpp` purescript-to-C++ transpiler, please see the [cpp branch](https://github.com/andyarvanitis/purescript-native/tree/cpp).
6+## Resources
6
7
7−#### Platforms
8+- [PureScript Book](https://leanpub.com/purescript/read)
8−* Although purescript-native should work on any platform supporting PureScript and modern C++ or Go, the generated code and resulting binary executables have been tested on:
9+- [Wiki](http://wiki.purescript.org)
9− * macOS Mojave 10.14.5 – full test suite
10+- [#purescript IRC @ FreeNode](http://webchat.freenode.net/?channels=purescript)
10− * For C++, Xcode 10.2.1's `clang` was used
11+- [Twitter](http://twitter.com/purescript)
11− * For Go, `go` version 1.12.7 was used
12+- [Try PureScript!](http://try.purescript.org/)
12− * Windows 10 x64 – full test suite
13+- [Release Notes](https://github.com/purescript/purescript/blob/master/RELEASE-0.6.md)
13− * C++: Visual Studio 2017 and `clang`
14+- [Contributing to PureScript](https://github.com/purescript/purescript/blob/master/CONTRIBUTING.md)
14− * Go: `go` version 1.12.7
15− * Linux Debian 9.5 amd64 – full test suite (C++)
16− * Default versions of `clang` and `gcc`
17− * Linux Debian 10 amd64 – full test suite (Go)
18− * Default version of `go`
19− * Raspberry Pi 3 B+ Raspbian official build (ARM), default versions of `clang` and `gcc`
20−
21−
22−#### Requirements for building `pscpp` and `psgo`
23−
24−* [Haskell Stack](https://docs.haskellstack.org/en/stable/README/) (if you're running macOS 10.14.5+, you can use pre-built binaries from [here](https://github.com/andyarvanitis/purescript-native/releases/))
25−
26−#### Requirements for using PureScript + purescript-native
27−
28−* A recent version (0.13+) of [purescript](https://github.com/purescript/purescript/releases).
29−
30−* For `pscpp`, a C++11-capable toolchain, e.g. recent versions of clang, gcc, Microsoft Visual Studio
31− * GNU Make + `psc-package` is the default supported build tool, but you should be able to use your favorite package manager, C++ build system, tools, debuggers, etc.
32−* For `psgo`, the [Go toolchain](https://golang.org) for your system
33− * You can use your favorite PureScript package manager and build tools – but for simplicity, [`spago`](https://github.com/spacchetti/spago) is recommended.
34−
35−
36−#### For more information and a Getting Started guide, please see
37−* [`pscpp`](https://github.com/andyarvanitis/purescript-native/blob/cpp/README-cpp.md)
38−* [`psgo`](https://github.com/andyarvanitis/purescript-native/blob/golang/README-go.md)
39−
40−
41−---
RELEASE-0.2.mdnew file+85
@@ -0,0 +1,85 @@
1+## 0.2.0 Changes
2+
3+Many thanks to the [contributors](https://github.com/purescript/purescript/graphs/contributors) who helped with this release.
4+
5+- Full language guide can be found [here](http://functorial.com/purescript).
6+- Try out the latest features [here](http://tryps.functorial.com).
7+
8+### New Features
9+
10+- RankNTypes
11+
12+ This experimental feature allows polymorphic types (introduced with `forall`) to appear on the left of a function arrow, or as the type of a record field, etc. For example:
13+
14+ rank2 :: (forall a. a -> a) -> Number
15+ rank2 = \f -> if f true then f 1 else f 2
16+
17+- Modules
18+- Polymorphic Object Update
19+
20+ Records now support member update in which the type of the field changes during the update. For example:
21+
22+ data Wrap a = Wrap a
23+
24+ update = \o -> o { prop = Wrap o.prop }
25+
26+### Enhancements
27+
28+- Naked expressions as statements
29+
30+ Naked expressions of type `{}` can now be used as statements.
31+
32+- Split code generation into `AST -> JS` and `JS -> String`
33+
34+ JavaScript generation is now split into the generation of a JavaScript AST, and the pretty-printing of that AST. This enables some optimizations, and a better JavaScript pretty-printer.
35+
36+- Syntactic sugar for introducing curried functions
37+
38+ Single-argument functions and multiple-argument functions can now be introduced in the same way:
39+
40+ test = \a (b, c) d -> a + b + c + d
41+
42+- JavaScript optimizations
43+
44+ Some basic dead-variable elimination, inlining and eta-conversion are now performed on the generated JavaScript.
45+
46+- Generate formatted Javascript
47+
48+ The generated JavaScript is now formatted to be more readable. In particular, newlines get generated, and the correct indentation is used.
49+
50+- More valid infix operators
51+
52+ The colon and period characters are now valid in infix operator names.
53+
54+### Syntax Changes
55+
56+- Avoid 'do' keyword for blocks
57+
58+ `do` will be used later for Haskell-like monad comprehensions, so its previous use in introducing blocks of statements is now invalid. The `do` keyword is still reserved.
59+
60+- Member foreign import syntax
61+
62+ A small syntactic addition to the FFI, to support a common use case.
63+
64+- Make FFI syntax match Haskell
65+
66+ Use `foreign import` instead of `extern`.
67+
68+- Make record declaration syntax match Haskell
69+- Simplify array binders
70+
71+ There are now two types of array binders: cons binders `x : xs -> ...` and array binders `[x, y, z] -> ...` instead of the previously confusing `[x:xs]`.
72+
73+- Array indexing syntax is ambiguous
74+
75+ Array elements are now accessed using the `!!` operator: `arr !! 0` etc.
76+
77+### Bug Fixes
78+
79+- Allow guards access to current scope
80+
81+### Libraries
82+
83+- Prelude
84+
85+ There is now a basic prelude in the `libraries/prelude` folder.
RELEASE-0.3.mdnew file+85
@@ -0,0 +1,85 @@
1+## 0.3.0 Changes
2+
3+Many thanks to the [contributors](https://github.com/purescript/purescript/graphs/contributors) who helped with this release.
4+
5+- Full language guide can be found [here](http://functorial.com/purescript).
6+- Try out the latest features [here](http://tryps.functorial.com).
7+
8+## New Features / Enhancements
9+
10+- Mutually recursive functions and types are now allowed within a module.
11+- Syntactic sugar for patterns in top-level declarations has been added. For example:
12+
13+ sum [] = 0
14+ sum (x:xs) = x + sum xs
15+
16+- Basic support for type classes has been added. Polymorphic types of the form `forall a. (C a) => ...` will not be inferred but can be checked. Type inference still works if all type class instances can be determined. There is not yet support for functionality like GHC's `FlexibleInstances`, `FlexibleContexts` or `MultiParamTypesClasses`. For example:
17+
18+ class Truthy a where
19+ isTrue :: a -> Boolean
20+
21+ instance Truthy Boolean where
22+ isTrue b = b
23+
24+ instance Truthy String where
25+ isTrue "" = false
26+ isTrue _ = true
27+
28+ ifThenElse :: forall a b. (Truthy a) => a -> b -> b -> b
29+ ifThenElse a tr fa = if isTrue a then tr else fa
30+
31+- There is now support for `do` notation, using the `Monad` type class from the `Prelude` module. For example:
32+
33+ data Maybe = Nothing | Just a
34+
35+ instance Prelude.Monad Maybe where
36+ ret = Just
37+ (>>=) Nothing _ = Nothing
38+ (>>=) (Just a) f = f a
39+
40+ test = do
41+ x <- Just 1
42+ y <- Just 2
43+ ret $ x + y
44+
45+- There is now a better story for side-effects. The `Eff` module in the `Prelude` defines a monad `Eff e` where e is a row of effect types. The kind system now defines a new kind `!` of effects. Row polymorphism allows different native effects to be interleaved. For example:
46+
47+ test = do
48+ trace "Testing"
49+ throwError "Error!"
50+
51+ has inferred type `forall eff. Eff (trace :: Trace | error :: Error String | eff)`.
52+ See the `/examples/passing/Eff.purs` file for a more in-depth set of examples.
53+ Supported native effects currently include `ST`, `Trace`, `Error` and `DOM` (via the `libraries/jquery` module).
54+- There is a new flag `--run-main` which will check the type of the `Main.main` function and emit the call to `main();` after all other generated Javascript.
55+- The `Prelude` module is now automatically included, unless the `--no-prelude` flag is specified.
56+- The class of accepted operator names has been expanded. Specifically, `$` is now a valid operator, and is defined in the `Prelude` module.
57+- Tail calls can be eliminated using the `--tco` flag.
58+- There is basic support for checking the types of values at runtime, using the `--runtime-type-checks` flag. Right now, this only works for primitive types, and so is a work-in-progress.
59+- GHCJS/Fay-style foreign imports are now supported. An example is
60+
61+ foreign import "function(n) { \
62+ \ return function(p) {\
63+ \ return Math.pow(n, p);\
64+ \ }\
65+ \ }" pow :: Number -> Number -> Number
66+- Data constructors now get imported along with their type definitions.
67+- The `-s` flag will now cause the compiler to use `stdin` for input.
68+- There is a new executable `psci` which provides simple REPL-like functionality - it parses expressions, passes the generated Javascript to Node for execution, and prints the result. This is a work-in-progress.
69+- The JQuery example (`libraries/jquery/test`) has been improved to use the new `Eff` monad and `do` notation.
70+
71+## Regressions
72+
73+- `foreach` is no longer supported. The `Prelude` module defines `map` which should provide the same functionality.
74+- Support for naked expressions as statements has been removed.
75+
76+## Bug Fixes
77+
78+- Operator precedence rules now work across modules.
79+- A bug in which expressions involving non-qualified names did not typecheck was fixed.
80+- Trailing spaces have been removed in the generated Javascript, thanks to @utkarshkukreti.
81+- Type synonyms now work properly across modules.
82+- Module imports are not transitive, which was previously leading to some unexpected error messages.
83+- A bug which caused the optimizer to break generated Javascript for mutually recursive values was fixed.
84+- Some `Prelude` functions which called methods in the standard Javascript library have been fixed.
85+
RELEASE-0.4.mdnew file+60
@@ -0,0 +1,60 @@
1+## 0.4.0 Changes
2+
3+This release focussed mainly on bug fixes and minor enhancements, in order to provide a stable release of the compiler.
4+
5+This release saw major contributions from [a number of new contributors](https://github.com/purescript/purescript/graphs/contributors). Thank you very much to everyone who submitted pull requests, issues and suggestions, and also to the users of the #purescript FreeNode channel for their valuable feedback. As always, new contributors are always welcome!
6+
7+- The full language guide can be found [here](http://purescript.readthedocs.org).
8+- Try out the latest features [here](http://tryps.functorial.com).
9+
10+## Breaking Changes
11+
12+- Multiple argument functions are no longer available.
13+- When used in the browser, PureScript modules are now accessed through `window.PS.<ModuleName>`. The `PS` object name can be changed via the `--browser-namespace` compiler argument.
14+- The `--run-main` argument has been replaced with `--main` which can now accept a module name in which to find the `main` function.
15+
16+### New Features
17+
18+- Dead code elimination. The new compiler argument `--module=` can be used to specify one or more modules that should be kept in the generated code along with their dependencies. If no modules are specified, all code is exported.
19+
20+### Enhancements
21+
22+- The `->` and `[]` types are now usable in type class instances.
23+- The file path is included in syntax error messages.
24+- Most reserved Javascript names (`return`, `const`, etc) are now usable.
25+- Generated code for operators is more user friendly (for example, `Prelude[">>="]`). Where this transformation cannot be applied, human-readable variable names (e.g. `$greater$greater$eq`) are generated.
26+- The typechecker's function application judgement was greatly simplified, and as a result, more valid things now typecheck.
27+- Data constructors with multiple arguments can now be defined.
28+- It is no longer necessary to sort modules in order of dependencies manually.
29+- Case statements matching data constructors no longer generate unnecessary constructor checks at runtime if there is only a single data constructor.
30+- New optimizer rules were added to inline JavaScript's built-in operators.
31+
32+### Bug Fixes
33+
34+- Floats parse correctly.
35+- Using data constructors in pattern matches now works properly across modules.
36+- PureScript modules no longer overwrite global objects with the same name.
37+- Show problems with shadowing of names were fixed.
38+- Problems with recursive non-function values were fixed.
39+- Type synonyms can now expand to types containing more type synonyms.
40+- A bug in capture-avoiding type variable substitution which was affecting the `Functor (Either e)` instance was fixed.
41+- Type synonym instances are now disallowed.
42+- Precedence rules for some basic operators were corrected.
43+- A bug which allowed skolem variables to escape their scope was add (thanks to Brian McKenna).
44+- Modules containing mutually recursive type synonyms and data declarations now compile correctly.
45+- A number of bugs in the optimizer were addressed.
46+
47+### Libraries
48+
49+- The `Prelude` has been greatly expanded. Definitions for built-in JavaScript operators have been moved into the Prelude.
50+- Gary Burgess has released the [grunt-purescript library](https://github.com/purescript/grunt-purescript) to build PureScript code using Grunt.
51+- The [purescript-parsing](https://github.com/purescript/purescript-parsing) library provides Parsec-like parsing combinators.
52+- The [purescript-promises](https://github.com/purescript/purescript-promises) library provides `Monad` and `Applicative` instances for promises.
53+- The [purescript-quickcheck](https://github.com/purescript/purescript-quickcheck) library provides a very basic implementation of a QuickCheck-style testing harness.
54+- The [purescript-json](https://github.com/purescript/purescript-json) library aims to provide a safe way to consume JSON data.
55+
56+### Documentation
57+
58+- Documentation for the `Prelude` modules is now automatically generated and can be found [here](http://purescript.readthedocs.org/en/latest/prelude.html).
59+- There is now Hackage documentation.
60+- Code comments have been improved.
RELEASE-0.5.mdnew file+99
@@ -0,0 +1,99 @@
1+## 0.5.0 Changes
2+
3+### Breaking Changes
4+
5+- Support for blocks has been removed. (paf31)
6+- Type class instances must now be named (paf31)
7+
8+ instance showNumber :: Show Number where
9+ ...
10+
11+- Prelude modules now follow a naming scheme similar to haskell (e.g. `Data.Maybe`, `Control.Monad`) (garyb)
12+- Many modules that were previously part of the Prelude have been split into individual libraries, [now distributed via Bower](http://bower.io/search/?q=purescript) (garyb)
13+- Multiple modules with the same name are now disallowed rather than merged (garyb)
14+- The `Prelude` module is now imported automatically. Conflicts can be avoided by using qualified imports or an explicit import list. (garyb, paf31)
15+- Overlapping instances are no longer allowed. The `Prelude` and core libraries have been updated accordingly. (paf31)
16+- `Functor`, `Applicative`, `Monad` are now part of a class heirarchy that include `Apply` and `Bind`. `return` is now an alias for `pure`. (joneshf, paf31, garyb)
17+- `Semigroupoid` is now a superclass of `Category` (garyb)
18+- `(:)` is now part of Prelude (garyb)
19+- `(!!)` has been renamed to `Prelude.Unsafe.unsafeIndex` and a safe version has been added to `Data.Array` (garyb)
20+
21+### New Features
22+
23+- Multi parameter typeclasses (paf31)
24+- Superclasses (puffnfresh, paf31)
25+- FlexibleInstances and FlexibleContexts (paf31)
26+- Let bindings are now supported. The `let` keyword can introduce several local (possibly mutually recursive) bindings, along with optional type signatures. (paf31)
27+- `where` clauses are now supported in value declarations, with the same rules as `let` bindings (garyb)
28+- Empty data declarations and empty type classes are now supported (paf31)
29+- A new command line option `--codegen` controls which modules will have Javascript and externs generated (paf31)
30+- `psc-make` now generates CommonJS-compatible modules, which can be used with `require()` in `node`. `psc` still generates modules for use in the browser. (paf31, garyb)
31+
32+### Enhancements
33+
34+- Pretty printing for row types was improved (garyb)
35+- Module names can now contain `.` (garyb)
36+- New optimizer rules have been added for code in the ST monad, to reproduce the functionality of the blocks feature, which has been removed (paf31)
37+- Pattern binders are now usable in lambda expression arguments (paf31)
38+- PSCI now has a `:t` command for checking the type of a value (paf31)
39+- Array pretty printing via `show` has been improved (joneshf)
40+- PSCI completions are sorted (joneshf)
41+- PSCI now has help commands (joneshf)
42+- PSCI history is in XDG config (joneshf)
43+- PSCI allows loading of modules from ~ paths (joneshf)
44+- PSCI can accept a list of modules to load on start from the command line (paf31)
45+- PSCI can now be configured using a `.psci` file in the current directory. If such a file exists, it should contain a list of commands to run on startup. (paf31)
46+- Type class instances are now named, to enable easier interop with Javascript (paf31)
47+- Class names no longer need to be qualified in instance declarations (garyb)
48+- Module exports can now be specified explicitly (garyb)
49+- Let bindings can now define functions with binders (paf31)
50+- Case statements and functions which do not pattern match on their arguments now generate smaller code (paf31)
51+- Imported type class instances are now exported (paf31)
52+- Some error messages were improved (paf31)
53+- Qualfied module imports are now supported as `import qualified M as X` (garyb)
54+- The escape check was removed, since it was too restrictive (paf31)
55+- The binary operator reordering step was greatly simplified (paf31)
56+- The Object type constructor can now be referenced explicitly as `Prim.Object` (with kind `# * -> *`) (paf31)
57+- Optimizations are now enabled by default and can be disabled with the `--no-tco` and `--no-magic-do` flags (garyb)
58+- Unary minus and signed numeric literals are now supported again (paf31, garyb)
59+- Type errors have been simplified, the full trace can be enabled with `--verbose-errors` or `-v` (paf31)
60+- Error messages now display source positions (paf31, garyb)
61+- The type classes implementation and code generation was greatly simplified (paf31)
62+- Object properties and row labels can now be accessed with arbitrary string names by using string literals (paf31)
63+- `(++)` is now an alias for the Semigroup operator `(<>)` (paf31)
64+- Error messages for classes with undefined or missing members have been improved (garyb)
65+- The SYB dependency was removed, and traversals rewritten by hand, for a large performance increase (paf31)
66+
67+### Bug Fixes
68+
69+- The subsumes relation has been fixed for object types (paf31)
70+- `sort` no longer mutates arrays (joneshf)
71+- PSCI now evaluates expressions (joneshf)
72+- Overlapping variables in typeclass instances are rejected (paf31)
73+- A bug in the optimizer related to inlining was fixed (paf31)
74+- A type checker bug related to array literals was fixed (paf31)
75+- Externs files (`--externs`) are now working again (paf31)
76+- Precedence of backticked infix functions have been corrected (paf31)
77+- A bug which allowed some incorrect type class instances to pass the type checker was fixed (paf31)
78+- Type synonyms are no longer restricted to kind `*` (paf31)
79+- Negative number literals have been restored (garyb)
80+- If a type defined in a module appears in an exported declaration it must also be exported from the module (garyb)
81+- Error messages for unresolvable types or values include the declaration name again (garyb)
82+- Characters in string literals are now properly escaped (garyb)
83+- A module containing a single orphan type declaration and no other declarations now fails to compile (garyb)
84+- An error involving ordering of type class instances was fixed (garyb, paf31)
85+- Externs files no longer include fixity declarations for members that were removed as dead code (garyb)
86+- A bug which prevented `sequence $ [Just 1]` from typechecking was fixed (paf31)
87+
88+### Libraries
89+
90+- Purescript libraries are now [distributed via Bower](http://bower.io/search/?q=purescript). There are currently around 40 libraries available.
91+
92+### Plugins
93+
94+- The `grunt-purescript` plugin has been updated to provide support for new command line options.
95+- There is a new `gulp-purescript` plugin available for compiling with Gulp.
96+
97+### Documentation
98+
99+- There is a new `hierarchy` executable which will generate `.dot` diagrams based on the type class hierarchy of a module. The Prelude docs have been updated to include such a type class diagram. (joneshf)
RELEASE-0.6.mdnew file+63
@@ -0,0 +1,63 @@
1+## 0.6 Changes
2+
3+### Breaking Changes
4+
5+- The `Alternative` type class hierarchy was refactored. See [here](https://github.com/purescript/purescript-control/issues/6).
6+- `--runtime-type-checks` has been removed. The recommended approach is to use `purescript-foreign`. (@garyb)
7+- The `Unit` type is now used in the Prelude and core libraries to represent values containing no data. (@garyb)
8+- The Prelude is no longer distributed as a separate file, but is embedded in the compiler executables. (@paf31)
9+
10+### New Features
11+
12+- Newtypes are now supported using the `newtype` keyword. The runtime representation of a newtype is identical to that of the contained type. (@garyb)
13+- Multiline string literals are now supported via triple-quote syntax, making FFI declarations much neater. (@phadej)
14+- Kind signatures on types and type constructor arguments are now supported. (@paf31)
15+
16+### Enhancements
17+
18+- The `runFnN` and `mkFnN` families of functions are now inlined by the optimizer, making interop with JavaScript functions of multiple arguments much simpler. (@paf31)
19+- Tail call optimization has been improved for functions using case expressions. (@paf31)
20+- Saturated calls to data constructors are now optimized. (@garyb)
21+- A new `Renamer` module now renames identifiers which shadow other names in scope, which greatly simplies code generation. (@garyb)
22+- `psci` now provides the following new options:
23+ - `:b` to browse a module (@ardumont)
24+ - `:s` to show current imports or modules (@ardumont)
25+ - `:k` to find the kind of a type constructor (@5outh)
26+- The approach to checking whether a name is initialized in the generated JavaScript was simplified (@paf31)
27+- The dependency on the `PureScript_paths` module has been removed, which makes distribution via binaries simpler. (@paf31)
28+- Nested `if` blocks now get optimized. (@garyb)
29+- Generated code for type class dictionaries was simplified. (@garyb, @dylex)
30+- The code generator now inserts the version of `psc` into the file as a comment. (@co-dh)
31+- `()` is now valid syntax, referring to the empty row. (@paf31)
32+- The type checker will now display multiple errors for type errors in the same binding group. (@paf31)
33+- Imports can now specify hidden names using `import ... hiding ( ... )` (@andreypopp)
34+
35+### Bug Fixes
36+
37+- Binding group errors in type class members are now caught at compile time. (@dylex)
38+- Some errors related to type checking rows with duplicate labels were fixed. (@paf31)
39+- Some issues with the calculation of binding groups were fixed. (@paf31)
40+- Error messages for invalid case declarations are now generated. (@natefaubion)
41+- Some issues related to module exports were fixed. (@garyb)
42+- `psci` now checks imports for validity. (@Bogdanp)
43+
44+### Libraries
45+
46+- The `Alternative` type class hierarchy was refactored (@joneshf, @garyb)
47+- The `exceptions` library no longer supports throwing exceptions of any type.
48+- The following libraries have been moved to the core PureScript organisation: (@garyb)
49+ - `purescript-transformers`
50+ - `purescript-free`
51+ - `purescript-const`
52+ - `purescript-identity`
53+ - `purescript-lazy`
54+ - `purescript-distributive`
55+ - `purescript-bifunctors`
56+ - `purescript-contravariant`
57+ - `purescript-profunctors`
58+ - `purescript-maps`
59+
60+### Documentation
61+
62+- The [PureScript book](https://leanpub.com/purescript/read) is now available.
63+- The [PureScript wiki](https://github.com/purescript/purescript/wiki) is now the main resource for compiler and library documentation.
Setup.hs+4
@@ -1,2 +1,6 @@
1+module Main where
2+
1import Distribution.Simple
3import Distribution.Simple
4+
5+main :: IO ()
2main = defaultMain
6main = defaultMain
app/Main.hsdeleted−250
@@ -1,250 +0,0 @@
1−{-# LANGUAGE OverloadedStrings #-}
2−{-# LANGUAGE RankNTypes #-}
3−{-# LANGUAGE TemplateHaskell #-}
4−
5−module Main where
6−
7−import Control.Monad (when)
8−import qualified Control.Monad.Parallel as Par
9−import Data.Aeson
10−import Data.Aeson.Types
11−import Data.Char
12−import Data.FileEmbed (embedFile)
13−import Data.List (delete, intercalate, isPrefixOf, nub, partition, (\\))
14−import Data.Maybe
15−import Data.Monoid ((<>))
16−import Data.Version
17−import Control.Monad.Supply
18−import Control.Monad.Supply.Class
19−import Text.Printf
20−
21−import System.Environment
22−import System.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist, getCurrentDirectory, getModificationTime)
23−import System.FilePath ((</>), joinPath, splitDirectories, takeDirectory)
24−import System.FilePath.Find
25−import System.Process
26−
27−import Data.Text (Text)
28−import qualified Data.Text as T
29−import qualified Data.Text.Encoding as T
30−import qualified Data.Text.Lazy as L
31−import qualified Data.Text.Lazy.Encoding as L
32−import qualified Data.ByteString as B
33−
34−import Development.GitRev
35−
36−import Language.PureScript.AST.Literals
37−import Language.PureScript.CoreFn
38−import Language.PureScript.CoreFn.FromJSON
39−
40−import CodeGen.IL
41−import CodeGen.IL.Common
42−import CodeGen.IL.Printer
43−
44−import Tests
45−
46−data Command = Build | Run (Maybe String)
47−
48−parseJson :: Text -> Value
49−parseJson text
50− | Just fileJson <- decode . L.encodeUtf8 $ L.fromStrict text = fileJson
51− | otherwise = error "Bad json"
52−
53−jsonToModule :: Value -> Module Ann
54−jsonToModule value =
55− case parse moduleFromJSON value of
56− Success (_, r) -> r
57− _ -> error "Failed parsing corefn. Psgo currently supports purescript <= 0.13.8"
58−
59−splitArgs :: [String] -> ([String], Maybe String, [String])
60−splitArgs args =
61− let (opts, files) = partition (isPrefixOf "--") args
62− opts' = (map . map) toLower opts
63− (moduleName, files') =
64− if null files
65− then (Nothing, files)
66− else
67− if "--run" `elem` opts' && length (files) >= 1
68− then do
69− let file0 = head files
70− files' = tail files
71− case file0 of
72− "Main.main" -> (Just "Main", files')
73− "Test.Main.main" -> (Just "Test.Main", files')
74− _ -> (Nothing, files)
75− else (Nothing, files)
76− in (opts, moduleName, files')
77−
78−main :: IO ()
79−main = do
80− args <- getArgs
81− -- let (opts, files) = partition (isPrefixOf "--") args
82− let (opts, moduleName, files) = splitArgs args
83− opts' = (map . map) toLower opts
84− if "--tests" `elem` opts'
85− then runTests
86− else do
87− if "--help" `elem` opts' || "--version" `elem` opts'
88− then do
89− when ("--help" `elem` opts') $ do
90− putStrLn help
91− when ("--version" `elem` opts') $ do
92− let branch = $(gitBranch)
93− details | branch == "golang" = "master, commit " ++ $(gitHash)
94− | otherwise = branch
95− putStrLn $ details ++ if $(gitDirty) then " (DIRTY)" else ""
96− else do
97− if null files
98− then do
99− currentDir <- getCurrentDirectory
100− processFiles opts' [currentDir]
101− else
102− processFiles opts' files
103− if "--run" `elem` opts
104− then runBuildTool $ Run moduleName
105− else when ("--no-build" `notElem` opts) $
106− runBuildTool Build
107− return ()
108− where
109− processFiles :: [String] -> [FilePath] -> IO ()
110− processFiles opts [file] = do
111− isDir <- doesDirectoryExist file
112− if isDir then do
113− files <- find always (fileName ==? corefn) file
114− if null files
115− then errorNoCorefnFiles
116− else generateFiles opts files
117− else generateFiles opts [file]
118− processFiles opts files = do
119− generateFiles opts files
120− basePath :: [FilePath] -> FilePath
121− basePath files =
122− let filepath = takeDirectory (head files) in
123− joinPath $ (init $ splitDirectories filepath)
124− generateFiles :: [String] -> [FilePath] -> IO ()
125− generateFiles opts files = do
126− let baseOutpath = basePath files
127− writeSupportFiles baseOutpath
128− Par.mapM (generateCode opts baseOutpath) files
129− return ()
130− runBuildTool :: Command -> IO ()
131− runBuildTool cmd = do
132− project <- projectEnv
133− case cmd of
134− Build -> do
135− callProcess "go" ["build", T.unpack project </> modPrefix' </> "Main"]
136− Run moduleName -> do
137− callProcess "go" ["run", T.unpack project </> modPrefix' </> fromMaybe "Main" moduleName]
138− return ()
139−
140−generateCode :: [String] -> FilePath -> FilePath -> IO ()
141−generateCode opts baseOutpath jsonFile = do
142− jsonModTime <- getModificationTime jsonFile
143− let filepath = takeDirectory jsonFile
144− dirparts = splitDirectories $ filepath
145− mname = last dirparts
146− basedir = joinPath $ init dirparts
147− mname' = T.pack mname
148− possibleFileName = basedir </> (T.unpack mname') </> implFileName mname'
149− exists <- doesFileExist possibleFileName
150− if exists
151− then do
152− modTime <- getModificationTime possibleFileName
153− when (modTime < jsonModTime) $
154− transpile opts baseOutpath jsonFile
155− else transpile opts baseOutpath jsonFile
156−
157−transpile :: [String] -> FilePath -> FilePath -> IO ()
158−transpile opts baseOutpath jsonFile = do
159− jsonText <- T.decodeUtf8 <$> B.readFile jsonFile
160− project <- projectEnv
161− let module' = jsonToModule $ parseJson jsonText
162− ((_, foreigns, asts, implHeader, implFooter), _) <- runSupplyT 5 (moduleToIL module' project)
163− let mn = moduleNameToIL' $ moduleName module'
164− implementation = prettyPrintIL asts
165− outpath = joinPath [baseOutpath, T.unpack mn]
166− implPath = outpath </> implFileName mn
167− createDirectoryIfMissing True outpath
168− putStrLn implPath
169− B.writeFile implPath $ T.encodeUtf8 (implHeader <> implementation <> implFooter)
170−
171−writeSupportFiles :: FilePath -> IO ()
172−writeSupportFiles baseOutpath = do
173− currentDir <- getCurrentDirectory
174− let outputdir = T.pack $ baseOutpath \\ currentDir
175− ffiOutpath = currentDir </> subdir
176− createDirectoryIfMissing True baseOutpath
177− createDirectoryIfMissing True ffiOutpath
178− writeModuleFile outputdir currentDir $(embedFile "support/go.mod.working")
179− writeModuleFile outputdir baseOutpath $(embedFile "support/go.mod.output")
180− writeModuleFile outputdir ffiOutpath $(embedFile "support/go.mod.ffi-loader")
181− writeLoaderFile ffiOutpath $(embedFile "support/ffi-loader.go")
182− where
183− writeModuleFile :: Text -> FilePath -> B.ByteString -> IO ()
184− writeModuleFile outputdir path modText = do
185− let goModSource = path </> "go.mod"
186− goModSourceExists <- doesFileExist goModSource
187− when (not goModSourceExists) $ do
188− project <- projectEnv
189− let project' = T.unpack project
190− outputdir' = tail $ T.unpack outputdir
191− modText' = T.replace "$PROJECT" project $ T.decodeUtf8 modText
192− replaceLoader = project' </> ffiLoader' <> "=." </> subdir
193− replaceOutput = project' </> modPrefix' <> "=." </> outputdir'
194− B.writeFile goModSource $ T.encodeUtf8 modText'
195− callProcess "go" ["mod", "edit", "-replace", replaceLoader]
196− callProcess "go" ["mod", "edit", "-replace", replaceOutput]
197− callProcess "go" ["clean", "-modcache"]
198− writeLoaderFile :: FilePath -> B.ByteString -> IO ()
199− writeLoaderFile ffiOutpath loaderText = do
200− let loaderSource = ffiOutpath </> "ffi_loader.go"
201− loaderSourceExists <- doesFileExist loaderSource
202− when (not loaderSourceExists) $ do
203− B.writeFile loaderSource loaderText
204−
205−implFileName :: Text -> FilePath
206−implFileName mn = ((\c -> if c == '.' then '_' else c) <$> T.unpack mn) <> ".go"
207−
208−projectEnv :: IO Text
209−projectEnv = do
210− T.pack . fromMaybe defaultProject <$> lookupEnv goproject
211−
212−help :: String
213−help = "Usage: psgo OPTIONS COREFN-FILES\n\
214− \ PureScript to native (via go) compiler\n\n\
215− \Available options:\n\
216− \ --help Show this help text\n\n\
217− \ --version Show the version number\n\n\
218− \ --run Run the generated go code directly, without building an\n\
219− \ executable\n\
220− \ --no-build Generate go source files, but do not build an executable\n\
221− \ --tests Run test cases (under construction)\n\n\
222− \See also:\n\
223− \ purs compile --help\n"
224−
225−corefn :: String
226−corefn = "corefn.json"
227−
228−goSrc :: String
229−goSrc = ".go"
230−
231−goproject :: String
232−goproject = "GOPROJECT"
233−
234−defaultProject :: String
235−defaultProject = "project.localhost"
236−
237−modPrefix' :: String
238−modPrefix' = T.unpack modPrefix
239−
240−ffiLoader' :: String
241−ffiLoader' = T.unpack ffiLoader
242−
243−subdir :: String
244−subdir = T.unpack modLabel
245−
246−errorNoCorefnFiles :: IO ()
247−errorNoCorefnFiles = do
248− ioError . userError $ "no compiled purescript '" <> corefn <> "' files found –\n" <>
249− " make sure to use the '--codegen corefn' option with your purs\n" <>
250− " project build tool"
bundle/.gitignorenew file+3
@@ -0,0 +1,3 @@
1+build/
2+*.tar.gz
3+*.sha
bundle/READMEnew file+20
@@ -0,0 +1,20 @@
1+ ____ ____ _ _
2+| _ \ _ _ _ __ ___/ ___| ___ _ __(_)_ __ | |_
3+| |_) | | | | '__/ _ \___ \ / __| '__| | '_ \| __|
4+| __/| |_| | | | __/___) | (__| | | | |_) | |_
5+|_| \__,_|_| \___|____/ \___|_| |_| .__/ \__|
6+ |_|
7+
8+Installation Instructions
9+-------------------------
10+
11+This bundle contains the following executables:
12+
13+- psc The PureScript compiler (generates JavaScript for use
14+ in the browser)
15+- psc-make The PureScript compiler (generates CommonJS modules)
16+- psci The PureScript interactive module (requires NodeJS)
17+- psc-docs A documentation generator
18+
19+Copy these files anywhere on your PATH.
20+
bundle/build.shnew file+43
@@ -0,0 +1,43 @@
1+set -e
2+
3+SCRIPTPATH=$( cd "$(dirname "$0")" ; pwd -P )
4+
5+OS=$1
6+
7+if [ -z $OS ]
8+then
9+ echo "Usage: build.sh osname"
10+ exit 1
11+fi
12+
13+pushd ${SCRIPTPATH} > /dev/null
14+
15+# Make the staging directory
16+mkdir -p build/purescript/
17+
18+# Strip the binaries
19+strip ../dist/build/psc/psc
20+strip ../dist/build/psci/psci
21+strip ../dist/build/psc-make/psc-make
22+strip ../dist/build/psc-docs/psc-docs
23+
24+# Copy files to staging directory
25+cp ../dist/build/psc/psc build/purescript/
26+cp ../dist/build/psci/psci build/purescript/
27+cp ../dist/build/psc-make/psc-make build/purescript/
28+cp ../dist/build/psc-docs/psc-docs build/purescript/
29+cp README build/purescript/
30+cp ../LICENSE build/purescript/
31+
32+# Make the binary bundle
33+pushd build > /dev/null
34+tar -zcvf ../$OS.tar.gz purescript
35+popd > /dev/null
36+
37+# Calculate the SHA hash
38+shasum $OS.tar.gz > $OS.sha
39+
40+# Remove the staging directory
41+rm -rf build/
42+
43+popd > /dev/null
bundle/winbuild.shnew file+40
@@ -0,0 +1,40 @@
1+## This Windows-specific version of build.sh can be run in an msys environment
2+## to create a .tar.gz bundle for Windows users.
3+## msysgit contains all of the pieces needed to run this script.
4+
5+set -e
6+
7+SCRIPTPATH=$( cd "$(dirname "$0")" ; pwd -P )
8+
9+pushd ${SCRIPTPATH}
10+
11+# Make the staging directory
12+mkdir -p build/purescript/
13+
14+# Strip the binaries
15+strip ../dist/build/psc/psc.exe
16+strip ../dist/build/psci/psci.exe
17+strip ../dist/build/psc-make/psc-make.exe
18+strip ../dist/build/psc-docs/psc-docs.exe
19+
20+# Copy files to staging directory
21+cp ../dist/build/psc/psc.exe build/purescript/
22+cp ../dist/build/psci/psci.exe build/purescript/
23+cp ../dist/build/psc-make/psc-make.exe build/purescript/
24+cp ../dist/build/psc-docs/psc-docs.exe build/purescript/
25+cp README build/purescript/
26+cp ../LICENSE build/purescript/
27+
28+# Make the binary bundle
29+pushd build
30+tar -zcvf ../win64.tar.gz purescript
31+popd
32+
33+# Calculate the MD5 hash
34+md5sum win64.tar.gz > win64.md5
35+
36+# Remove the staging directory
37+rm -rf build/
38+
39+popd
40+
default.nixdeleted−23
@@ -1,23 +0,0 @@
1−let
2− haskellNix = import (builtins.fetchTarball https://github.com/input-output-hk/haskell.nix/archive/master.tar.gz) {};
3− nixpkgsSrc = haskellNix.sources.nixpkgs-1903; # has hsc2hs-0.68.4
4−
5− hsc2hsOverlay = self: super: {
6− buildPackages = super.buildPackages // {
7− hsc2hs = super.haskellPackages.hsc2hs;
8− };
9− };
10−
11− nixpkgsArgs = haskellNix.nixpkgsArgs // {
12− overlays = haskellNix.nixpkgsArgs.overlays ++ [ hsc2hsOverlay ];
13− };
14−in
15−{ pkgs ? import nixpkgsSrc nixpkgsArgs
16−}:
17−
18−pkgs.haskell-nix.stackProject {
19− src = pkgs.haskell-nix.haskellLib.cleanGit {
20− name = "purescript-native";
21− src = ./.;
22− };
23−}
examples/.gitignorenew file+1
@@ -0,0 +1 @@
1+shelltest/tests
examples/failing/ArrayType.pursnew file+11
@@ -0,0 +1,11 @@
1+module Main where
2+
3+import Debug.Trace
4+
5+bar :: Number -> Number -> Number
6+bar n m = n + m
7+
8+foo = x `bar` y
9+ where
10+ x = 1
11+ y = []
examples/failing/Arrays.pursnew file+5
@@ -0,0 +1,5 @@
1+module Main where
2+
3+ import Prelude
4+
5+ test = \arr -> arr !! (0 !! 0)
examples/failing/Do.pursnew file+8
@@ -0,0 +1,8 @@
1+module Main where
2+
3+test1 = do let x = 1
4+
5+test2 y = do x <- y
6+
7+test3 = do return 1
8+ return 2
examples/failing/DuplicateProperties1.pursnew file+9
@@ -0,0 +1,9 @@
1+module DuplicateProperties where
2+
3+foreign import data Test :: # * -> *
4+
5+foreign import subtractX "" :: forall r. Test (x :: Unit | r) -> Test r
6+
7+foreign import hasX "" :: Test (x :: Unit, y :: Unit)
8+
9+baz = subtractX (subtractX hasX)
examples/failing/DuplicateProperties2.pursnew file+9
@@ -0,0 +1,9 @@
1+module DuplicateProperties where
2+
3+foreign import data Test :: # * -> *
4+
5+foreign import subtractX "" :: forall r. Test (x :: Unit | r) -> Test r
6+
7+foreign import hasX "" :: forall r. Test (x :: Unit, y :: Unit | r)
8+
9+baz = subtractX (subtractX hasX)
examples/failing/DuplicateTypeVars.pursnew file+3
@@ -0,0 +1,3 @@
1+module Main where
2+
3+type Foo a a = a
examples/failing/Foldable.pursnew file+12
@@ -0,0 +1,12 @@
1+module Main where
2+
3+class Foldable f where
4+ fold :: forall a b. (a -> b -> b) -> b -> f a -> b
5+ size :: forall a. f a -> Number
6+
7+instance foldableArray :: Foldable [] where
8+ fold _ z [] = z
9+ fold f z (x:xs) = x `f` (fold f z xs)
10+ size = fold (const ((+) 1)) 0
11+
12+x = size [1,2,3]
examples/failing/InstanceExport.pursnew file+15
@@ -0,0 +1,15 @@
1+module InstanceExport (S(..), f) where
2+
3+newtype S = S String
4+
5+class F a where
6+ f :: a -> String
7+
8+instance fs :: F S where
9+ f (S s) = s
10+
11+module Test where
12+
13+import InstanceExport
14+
15+test = f $ S "Test"
examples/failing/KindError.pursnew file+3
@@ -0,0 +1,3 @@
1+module Main where
2+
3+ data KindError f a = One f | Two (f a)
examples/failing/Let.pursnew file+3
@@ -0,0 +1,3 @@
1+module Main where
2+
3+test = let x = x in x
examples/failing/MPTCs.pursnew file+7
@@ -0,0 +1,7 @@
1+module Main where
2+
3+class Foo a where
4+ f :: a -> a
5+
6+instance fooStringString :: Foo String String where
7+ f a = a
examples/failing/MissingClassExport.pursnew file+4
@@ -0,0 +1,4 @@
1+module Test (bar) where
2+
3+ class Foo a where
4+ bar :: a -> a
examples/failing/MissingClassMemberExport.pursnew file+4
@@ -0,0 +1,4 @@
1+module Test (Foo) where
2+
3+ class Foo a where
4+ bar :: a -> a
examples/failing/MultipleErrors.pursnew file+9
@@ -0,0 +1,9 @@
1+module MultipleErrors where
2+
3+foo :: Number -> Number
4+foo 0 = "Test"
5+foo n = bar (n - 1)
6+
7+bar :: Number -> Number
8+bar 0 = "Test"
9+bar n = foo (n - 1)
examples/failing/MultipleErrors2.pursnew file+5
@@ -0,0 +1,5 @@
1+module MultipleErrors2 where
2+
3+foo = itDoesntExist
4+
5+bar = neitherDoesThis
examples/failing/MutRec.pursnew file+5
@@ -0,0 +1,5 @@
1+module MutRec where
2+
3+x = y
4+
5+y = x
examples/failing/MutRec2.pursnew file+3
@@ -0,0 +1,3 @@
1+module Main where
2+
3+x = x
examples/failing/NewtypeMultiArgs.pursnew file+3
@@ -0,0 +1,3 @@
1+module Main where
2+
3+newtype Thing = Thing String Boolean
examples/failing/NewtypeMultiCtor.pursnew file+3
@@ -0,0 +1,3 @@
1+module Main where
2+
3+newtype Thing = Thing String | Other
examples/failing/NoOverlap.pursnew file+11
@@ -0,0 +1,11 @@
1+module Main where
2+
3+data Foo = Foo
4+
5+instance showFoo1 :: Show Foo where
6+ show _ = "Foo"
7+
8+instance showFoo2 :: Show Foo where
9+ show _ = "Bar"
10+
11+test = show Foo
examples/failing/NullaryAbs.pursnew file+3
@@ -0,0 +1,3 @@
1+module Main where
2+
3+ func = \ -> "no"
examples/failing/Object.pursnew file+5
@@ -0,0 +1,5 @@
1+module Main where
2+
3+test o = o.foo
4+
5+test1 = test {}
examples/failing/OverlappingArguments.pursnew file+3
@@ -0,0 +1,3 @@
1+module OverlappingArguments where
2+
3+f x x = x
examples/failing/OverlappingBinders.pursnew file+4
@@ -0,0 +1,4 @@
1+module OverlappingBinders where
2+
3+f x = case x of
4+ (y:y@(z:zs)) -> y
examples/failing/OverlappingInstances.pursnew file+11
@@ -0,0 +1,11 @@
1+module OverlappingInstances where
2+
3+data A = A
4+
5+instance showA1 :: Show A where
6+ show A = "Instance 1"
7+
8+instance showA2 :: Show A where
9+ show A = "Instance 2"
10+
11+main = Debug.Trace.trace $ show A
examples/failing/OverlappingInstances2.pursnew file+23
@@ -0,0 +1,23 @@
1+module OverlappingInstances where
2+
3+data A = A | B
4+
5+instance eqA1 :: Eq A where
6+ (==) A A = true
7+ (==) B B = true
8+ (==) _ _ = false
9+ (/=) x y = not (x == y)
10+
11+instance eqA2 :: Eq A where
12+ (==) _ _ = true
13+ (/=) _ _ = false
14+
15+instance ordA :: Ord A where
16+ compare A B = LT
17+ compare B A = GT
18+ compare _ _ = EQ
19+
20+test :: forall a. (Ord a) => a -> a -> String
21+test x y = show $ x == y
22+
23+main = Debug.Trace.trace $ test A B
examples/failing/OverlappingVars.pursnew file+12
@@ -0,0 +1,12 @@
1+module Main where
2+
3+class OverlappingVars a where
4+ f :: a -> a
5+
6+data Foo a b = Foo a b
7+
8+instance overlappingVarsFoo :: OverlappingVars (Foo a a) where
9+ f a = a
10+
11+test = f (Foo "" 0)
12+
examples/failing/Rank2Types.pursnew file+7
@@ -0,0 +1,7 @@
1+module Main where
2+
3+ import Prelude
4+
5+ foreign import test :: (forall a. a -> a) -> Number
6+
7+ test1 = test (\n -> n + 1)
examples/failing/Reserved.pursnew file+4
@@ -0,0 +1,4 @@
1+module Main where
2+
3+(<) :: Number -> Number -> Number
4+(<) a b = !(a >= b)
examples/failing/SkolemEscape.pursnew file+5
@@ -0,0 +1,5 @@
1+module Main where
2+
3+ foreign import foo :: (forall a. a -> a) -> Number
4+
5+ test = \x -> foo x
examples/failing/SkolemEscape2.pursnew file+9
@@ -0,0 +1,9 @@
1+module Main where
2+
3+import Prelude
4+import Control.Monad.Eff
5+import Control.Monad.ST
6+
7+test _ = do
8+ r <- runST (newSTRef 0)
9+ return 0
examples/failing/Superclasses1.pursnew file+11
@@ -0,0 +1,11 @@
1+module Main where
2+
3+class Su a where
4+ su :: a -> a
5+
6+class (Su a) <= Cl a where
7+ cl :: a -> a -> a
8+
9+instance clNumber :: Cl Number where
10+ cl n m = n + m
11+
examples/failing/Superclasses2.pursnew file+9
@@ -0,0 +1,9 @@
1+module CycleInSuperclasses where
2+
3+class (Foo a) <= Bar a
4+
5+class (Bar a) <= Foo a
6+
7+instance barString :: Bar String
8+
9+instance fooString :: Foo String
examples/failing/Superclasses3.pursnew file+5
@@ -0,0 +1,5 @@
1+module UnknownSuperclassTypeVar where
2+
3+class Foo a
4+
5+class (Foo b) <= Bar a
examples/failing/Superclasses4.pursnew file+12
@@ -0,0 +1,12 @@
1+module OverlappingInstances where
2+
3+class Foo a
4+
5+instance foo1 :: Foo Number
6+
7+instance foo2 :: Foo Number
8+
9+test :: forall a. (Foo a) => a -> a
10+test a = a
11+
12+test1 = test 0
examples/failing/TopLevelCaseNoArgs.pursnew file+4
@@ -0,0 +1,4 @@
1+module Main where
2+ foo :: Number
3+ foo = 1
4+ foo = 2
examples/failing/TypeClassInstances.pursnew file+8
@@ -0,0 +1,8 @@
1+module Main where
2+
3+class A a where
4+ a :: a -> String
5+ b :: a -> Number
6+
7+instance aString :: A String where
8+ a s = s
examples/failing/TypeClasses2.pursnew file+8
@@ -0,0 +1,8 @@
1+module Main where
2+
3+import Prelude ()
4+
5+class Show a where
6+ show :: a -> String
7+
8+test = show "testing"
examples/failing/TypeError.pursnew file+5
@@ -0,0 +1,5 @@
1+module Main where
2+
3+ import Prelude
4+
5+ test = 1 ++ "A"
examples/failing/TypeSynonyms.pursnew file+5
@@ -0,0 +1,5 @@
1+module Main where
2+
3+type T1 = [T2]
4+
5+type T2 = T1
examples/failing/TypeSynonyms2.pursnew file+9
@@ -0,0 +1,9 @@
1+module Main where
2+
3+class Foo a where
4+ foo :: a -> String
5+
6+type Bar = String
7+
8+instance fooBar :: Foo Bar where
9+ foo s = s
examples/failing/TypeSynonyms3.pursnew file+9
@@ -0,0 +1,9 @@
1+module Main where
2+
3+class Foo a where
4+ foo :: a -> String
5+
6+type Bar = String
7+
8+instance fooBar :: Foo Bar where
9+ foo s = s
examples/failing/UnifyInTypeInstanceLookup.pursnew file+17
@@ -0,0 +1,17 @@
1+module Main where
2+
3+data Z = Z
4+data S n = S n
5+
6+data T
7+data F
8+
9+class EQ x y b
10+instance eqT :: EQ x x T
11+instance eqF :: EQ x y F
12+
13+foreign import test :: forall a b. (EQ a b T) => a -> b -> a
14+
15+foreign import anyNat :: forall a. a
16+
17+test1 = test anyNat (S Z)
examples/failing/UnknownType.pursnew file+4
@@ -0,0 +1,4 @@
1+module Main where
2+
3+test :: Number -> Something
4+test = {}
examples/failing/UnknownValue.pursnew file+25
@@ -0,0 +1,25 @@
1+module Main where
2+
3+import Prelude
4+import Control.Monad.Eff
5+import Control.Monad.ST
6+import Debug.Trace
7+
8+test = runSTArray (do
9+ a <- newSTArray 2 0
10+ pokeSTArray a 0 1
11+ pokeSTArray a 1 2
12+ return a)
13+
14+fromTo lo hi = runSTArray (do
15+ arr <- newSTArray (hi - lo + 1) 0
16+ (let
17+ go lo hi _ arr | lo > hi = return arr
18+ go lo hi i arr = do
19+ pokeSTArray arrr i lo
20+ go (lo + 1) hi (i + 1) arr
21+ in go lo hi 0 arr))
22+
23+main = do
24+ let t1 = runPure (fromTo 10 20)
25+ trace "Done"
examples/manual/failing/ArgLengthMismatch.pursnew file+4
@@ -0,0 +1,4 @@
1+module ArgLengthMismatch where
2+
3+ f x y = true
4+ f = false
examples/manual/failing/ExportExplicit.pursnew file+5
@@ -0,0 +1,5 @@
1+-- should fail as z does not exist in the module
2+module M1 (x, y, z) where
3+
4+ x = 1
5+ y = 2
examples/manual/failing/ExportExplicit1.pursnew file+14
@@ -0,0 +1,14 @@
1+module M1 (X(X)) where
2+
3+ data X = X | Y
4+
5+module Main where
6+
7+ import M1
8+
9+ testX = X
10+
11+ -- should fail as Y constructor is not exported from M1
12+ testY = Y
13+
14+ main = Debug.Trace.trace "Done"
examples/manual/failing/ExportExplicit2.pursnew file+5
@@ -0,0 +1,5 @@
1+-- should fail as Y is not a data constructor for X
2+module M1 (X(Y)) where
3+
4+ data X = X
5+ data Y = Y
examples/manual/failing/ExportExplicit3.pursnew file+13
@@ -0,0 +1,13 @@
1+module M1 (X(..)) where
2+
3+ data X = X | Y
4+ data Z = Z
5+
6+module Main where
7+
8+ import M1
9+
10+ -- should fail as Z is not exported from M1
11+ testZ = M1.Z
12+
13+ main = Debug.Trace.trace "Done"
examples/manual/failing/ImportExplicit.pursnew file+7
@@ -0,0 +1,7 @@
1+module M1 where
2+
3+ foo = "foo"
4+
5+module Main where
6+
7+ import M1 (X(..))
examples/manual/failing/ImportExplicit2.pursnew file+7
@@ -0,0 +1,7 @@
1+module M1 where
2+
3+ data X = Y
4+
5+module Main where
6+
7+ import M1 (X(Z, Q))
examples/manual/failing/ImportModule.pursnew file+7
@@ -0,0 +1,7 @@
1+module M2 where
2+
3+ data X = X
4+
5+module Main where
6+
7+ import M1
examples/manual/failing/OrphanTypeDecl.pursnew file+3
@@ -0,0 +1,3 @@
1+module OrphanTypeDecl where
2+
3+ fn :: Number -> Boolean
examples/manual/failing/RedefinedFixity.pursnew file+6
@@ -0,0 +1,6 @@
1+module RedefinedFixity where
2+
3+ (!?) x y = x + y
4+
5+ infix 2 !?
6+ infix 2 !?
examples/manual/failing/RequiredHiddenType.pursnew file+8
@@ -0,0 +1,8 @@
1+-- exporting `a` should fail as `A` is hidden
2+module Foo (B(..), a, b) where
3+
4+ data A = A
5+ data B = B
6+
7+ a = A
8+ b = B
examples/manual/passing/ExportExplicit.pursnew file+20
@@ -0,0 +1,20 @@
1+module M1 (X(X), Z(..), foo) where
2+
3+ data X = X | Y
4+ data Z = Z
5+
6+ foo :: Number
7+ foo = 0
8+
9+ bar :: Number
10+ bar = 1
11+
12+module Main where
13+
14+ import M1
15+
16+ testX = X
17+ testZ = Z
18+ testFoo = foo
19+
20+ main = Debug.Trace.trace "Done"
examples/manual/passing/ExportExplicit2.pursnew file+15
@@ -0,0 +1,15 @@
1+module M1 (bar) where
2+
3+ foo :: Number
4+ foo = 0
5+
6+ bar :: Number
7+ bar = foo
8+
9+module Main where
10+
11+ import M1
12+
13+ testBar = bar
14+
15+ main = Debug.Trace.trace "Done"
examples/manual/passing/Import.pursnew file+19
@@ -0,0 +1,19 @@
1+module M1 where
2+
3+ import Prelude ()
4+
5+ id :: forall a. a -> a
6+ id = \x -> x
7+
8+ foo = id
9+
10+module M2 where
11+
12+ import Prelude ()
13+ import M1
14+
15+ main = \_ -> foo 42
16+
17+module Main where
18+
19+main = Debug.Trace.trace "Done"
examples/manual/passing/ImportExplicit.pursnew file+14
@@ -0,0 +1,14 @@
1+module M1 where
2+
3+ data X = X | Y
4+ data Z = Z
5+
6+module Main where
7+
8+ import M1 (X(..))
9+
10+ testX :: X
11+ testX = X
12+ testY = Y
13+
14+ main = Debug.Trace.trace "Done"
examples/manual/passing/ImportQualified.pursnew file+12
@@ -0,0 +1,12 @@
1+module M1 where
2+
3+ trace x = x
4+
5+module Main where
6+
7+ import Prelude
8+ import Control.Monad.Eff
9+ import M1
10+ import qualified Debug.Trace as T
11+
12+ main = T.trace (trace "Done")
examples/manual/passing/Module.pursnew file+28
@@ -0,0 +1,28 @@
1+module M1 where
2+
3+ import Prelude
4+
5+ data Foo = Foo String
6+
7+ foo :: M1.Foo -> String
8+ foo = \f -> case f of Foo s -> s ++ "foo"
9+
10+ bar :: Foo -> String
11+ bar = foo
12+
13+ incr :: Number -> Number
14+ incr x = x + 1
15+
16+module M2 where
17+
18+ import Prelude
19+
20+ baz :: M1.Foo -> String
21+ baz = M1.foo
22+
23+ match :: M1.Foo -> String
24+ match = \f -> case f of M1.Foo s -> s ++ "foo"
25+
26+module Main where
27+
28+main = Debug.Trace.trace "Done"
examples/manual/passing/ModuleDeps.pursnew file+17
@@ -0,0 +1,17 @@
1+module M1 where
2+
3+import M2
4+
5+foo = M3.baz
6+
7+module M2 where
8+
9+bar = M3.baz
10+
11+module M3 where
12+
13+baz = 1
14+
15+module Main where
16+
17+main = Debug.Trace.trace "Done"
examples/manual/passing/RedefinedFixity.pursnew file+24
@@ -0,0 +1,24 @@
1+module M1 where
2+
3+import Prelude ()
4+
5+($) f a = f a
6+
7+infixr 1000 $
8+
9+module M2 where
10+
11+import Prelude ()
12+
13+import M1
14+
15+module M3 where
16+
17+import Prelude ()
18+
19+import M1
20+import M2
21+
22+module Main where
23+
24+main = Debug.Trace.trace "Done"
examples/passing/652.pursnew file+15
@@ -0,0 +1,15 @@
1+module Main where
2+
3+class Foo a b
4+
5+class Bar a c
6+
7+class (Foo a b, Bar a c) <= Baz a b c
8+
9+instance foo :: Foo (a -> b) a
10+
11+instance bar :: Bar (a -> b) b
12+
13+instance baz :: (Eq a) => Baz (a -> b) a b
14+
15+main = Debug.Trace.trace "Done"
examples/passing/Applicative.pursnew file+16
@@ -0,0 +1,16 @@
1+module Main where
2+
3+import Prelude ()
4+
5+class Applicative f where
6+ pure :: forall a. a -> f a
7+ (<*>) :: forall a b. f (a -> b) -> f a -> f b
8+
9+data Maybe a = Nothing | Just a
10+
11+instance applicativeMaybe :: Applicative Maybe where
12+ pure = Just
13+ (<*>) (Just f) (Just a) = Just (f a)
14+ (<*>) _ _ = Nothing
15+
16+main = Debug.Trace.trace "Done"
examples/passing/ArrayType.pursnew file+9
@@ -0,0 +1,9 @@
1+module Main where
2+
3+class Pointed p where
4+ point :: forall a. a -> p a
5+
6+instance pointedArray :: Pointed [] where
7+ point a = [a]
8+
9+main = Debug.Trace.trace "Done"
examples/passing/Arrays.pursnew file+24
@@ -0,0 +1,24 @@
1+module Main where
2+
3+import Prelude.Unsafe (unsafeIndex)
4+
5+test1 arr = arr `unsafeIndex` 0 + arr `unsafeIndex` 1 + 1
6+
7+test2 = \arr -> case arr of
8+ [x, y] -> x + y
9+ [x] -> x
10+ [] -> 0
11+ (x : y : _) -> x + y
12+
13+data Tree = One Number | Some [Tree]
14+
15+test3 = \tree sum -> case tree of
16+ One n -> n
17+ Some (n1 : n2 : rest) -> test3 n1 sum * 10 + test3 n2 sum * 5 + sum rest
18+
19+test4 = \arr -> case arr of
20+ [] -> 0
21+ [_] -> 0
22+ x : y : xs -> x * y + test4 xs
23+
24+main = Debug.Trace.trace "Done"
examples/passing/Auto.pursnew file+13
@@ -0,0 +1,13 @@
1+module Main where
2+
3+ data Auto s i o = Auto { state :: s, step :: s -> i -> o }
4+
5+ type SomeAuto i o = forall r. (forall s. Auto s i o -> r) -> r
6+
7+ exists :: forall s i o. s -> (s -> i -> o) -> SomeAuto i o
8+ exists = \state step f -> f (Auto { state: state, step: step })
9+
10+ run :: forall i o. SomeAuto i o -> i -> o
11+ run = \s i -> s (\a -> case a of Auto a -> a.step a.state i)
12+
13+ main = Debug.Trace.trace "Done"
examples/passing/AutoPrelude.pursnew file+8
@@ -0,0 +1,8 @@
1+module Main where
2+
3+import Debug.Trace
4+
5+f x = x * 10
6+g y = y - 10
7+
8+main = trace $ show $ (f <<< g) 100
examples/passing/AutoPrelude2.pursnew file+9
@@ -0,0 +1,9 @@
1+module Main where
2+
3+import qualified Prelude as P
4+import Debug.Trace
5+
6+f :: forall a. a -> a
7+f = P.id
8+
9+main = P.($) trace ((f P.<<< f) "Done")
examples/passing/BindersInFunctions.pursnew file+16
@@ -0,0 +1,16 @@
1+module Main where
2+
3+import Prelude
4+
5+tail = \(_:xs) -> xs
6+
7+foreign import error
8+ "function error(msg) {\
9+ \ throw msg;\
10+ \}" :: forall a. String -> a
11+
12+main =
13+ let ts = tail [1, 2, 3] in
14+ if ts == [2, 3]
15+ then Debug.Trace.trace "Done"
16+ else error "Incorrect result from 'tails'."
examples/passing/BindingGroups.pursnew file+8
@@ -0,0 +1,8 @@
1+module Main where
2+
3+foo = bar
4+ where bar r = r + 1
5+
6+r = foo 2
7+
8+main = Debug.Trace.trace "Done"
examples/passing/BlockString.pursnew file+12
@@ -0,0 +1,12 @@
1+module Main where
2+
3+foreign import foo """
4+ function foo(s) {
5+ return s;
6+ }
7+""" :: String -> String
8+
9+bar :: String -> String
10+bar _ = foo "test"
11+
12+main = Debug.Trace.trace "Done"
examples/passing/CheckSynonymBug.pursnew file+14
@@ -0,0 +1,14 @@
1+module Main where
2+
3+ import Prelude
4+
5+ type Foo a = [a]
6+
7+ foreign import length
8+ "function length(a) {\
9+ \ return a.length;\
10+ \}" :: forall a. [a] -> Number
11+
12+ foo _ = length ([] :: Foo Number)
13+
14+ main = Debug.Trace.trace "Done"
examples/passing/CheckTypeClass.pursnew file+16
@@ -0,0 +1,16 @@
1+module Main where
2+
3+ data Bar a = Bar
4+ data Baz
5+
6+ class Foo a where
7+ foo :: Bar a -> Baz
8+
9+ foo_ :: forall a. (Foo a) => a -> Baz
10+ foo_ x = foo ((mkBar :: forall a. (Foo a) => a -> Bar a) x)
11+
12+ mkBar :: forall a. a -> Bar a
13+ mkBar _ = Bar
14+
15+ main = Debug.Trace.trace "Done"
16+
examples/passing/Church.pursnew file+18
@@ -0,0 +1,18 @@
1+module Main where
2+
3+ import Prelude ()
4+
5+ type List a = forall r. r -> (a -> r -> r) -> r
6+
7+ empty :: forall a. List a
8+ empty = \r f -> r
9+
10+ cons :: forall a. a -> List a -> List a
11+ cons = \a l r f -> f a (l r f)
12+
13+ append :: forall a. List a -> List a -> List a
14+ append = \l1 l2 r f -> l2 (l1 r f) f
15+
16+ test = append (cons 1 empty) (cons 2 empty)
17+
18+ main = Debug.Trace.trace "Done"
examples/passing/Collatz.pursnew file+18
@@ -0,0 +1,18 @@
1+module Main where
2+
3+import Prelude
4+import Control.Monad.Eff
5+import Control.Monad.ST
6+
7+collatz :: Number -> Number
8+collatz n = runPure (runST (do
9+ r <- newSTRef n
10+ count <- newSTRef 0
11+ untilE $ do
12+ modifySTRef count $ (+) 1
13+ m <- readSTRef r
14+ writeSTRef r $ if m % 2 == 0 then m / 2 else 3 * m + 1
15+ return $ m == 1
16+ readSTRef count))
17+
18+main = Debug.Trace.print $ collatz 1000
examples/passing/Comparisons.pursnew file+23
@@ -0,0 +1,23 @@
1+module Main where
2+
3+import Control.Monad.Eff
4+import Debug.Trace
5+
6+foreign import data Assert :: !
7+
8+foreign import assert
9+ "function assert(x) {\
10+ \ return function () {\
11+ \ if (!x) throw new Error('assertion failed');\
12+ \ return {};\
13+ \ };\
14+ \};" :: forall e. Boolean -> Eff (assert :: Assert | e) Unit
15+
16+main = do
17+ assert (1 < 2)
18+ assert (2 == 2)
19+ assert (3 > 1)
20+ assert ("a" < "b")
21+ assert ("a" == "a")
22+ assert ("z" > "a")
23+ trace "Done!"
examples/passing/Conditional.pursnew file+9
@@ -0,0 +1,9 @@
1+module Main where
2+
3+ import Prelude ()
4+
5+ fns = \f -> if f true then f else \x -> x
6+
7+ not = \x -> if x then false else true
8+
9+ main = Debug.Trace.trace "Done"
examples/passing/Console.pursnew file+13
@@ -0,0 +1,13 @@
1+module Main where
2+
3+import Prelude
4+import Control.Monad.Eff
5+import Debug.Trace
6+
7+replicateM_ :: forall m a. (Monad m) => Number -> m a -> m {}
8+replicateM_ 0 _ = return {}
9+replicateM_ n act = do
10+ act
11+ replicateM_ (n - 1) act
12+
13+main = replicateM_ 10 (trace "Hello World!")
examples/passing/DataAndType.pursnew file+7
@@ -0,0 +1,7 @@
1+module Main where
2+
3+data A = A B
4+
5+type B = A
6+
7+main = Debug.Trace.trace "Done"
examples/passing/DeepArrayBinder.pursnew file+16
@@ -0,0 +1,16 @@
1+module Main where
2+
3+import Control.Monad.Eff
4+
5+match2 :: [Number] -> Number
6+match2 (x : y : xs) = x * y + match2 xs
7+match2 _ = 0
8+
9+foreign import explode
10+ "function explode() {\
11+ \ throw new Error('Incorrect result');\
12+ \}" :: forall eff a. Eff eff a
13+
14+main = case match2 [1, 2, 3, 4, 5, 6, 7, 8, 9] of
15+ 100 -> Debug.Trace.trace "Done"
16+ _ -> explode
examples/passing/DeepCase.pursnew file+14
@@ -0,0 +1,14 @@
1+module Main where
2+
3+import Debug.Trace
4+import Control.Monad.Eff
5+import Control.Monad.ST
6+
7+f x y =
8+ let
9+ g = case y of
10+ 0 -> x
11+ x -> 1 + x * x
12+ in g + x + y
13+
14+main = print $ f 1 10
examples/passing/Do.pursnew file+67
@@ -0,0 +1,67 @@
1+module Main where
2+
3+import Prelude
4+
5+data Maybe a = Nothing | Just a
6+
7+instance functorMaybe :: Functor Maybe where
8+ (<$>) f Nothing = Nothing
9+ (<$>) f (Just x) = Just (f x)
10+
11+instance applyMaybe :: Apply Maybe where
12+ (<*>) (Just f) (Just x) = Just (f x)
13+ (<*>) _ _ = Nothing
14+
15+instance applicativeMaybe :: Applicative Maybe where
16+ pure = Just
17+
18+instance bindMaybe :: Bind Maybe where
19+ (>>=) Nothing _ = Nothing
20+ (>>=) (Just a) f = f a
21+
22+instance monadMaybe :: Prelude.Monad Maybe
23+
24+test1 = \_ -> do
25+ Just "abc"
26+
27+test2 = \_ -> do
28+ (x : _) <- Just [1, 2, 3]
29+ (y : _) <- Just [4, 5, 6]
30+ Just (x + y)
31+
32+test3 = \_ -> do
33+ Just 1
34+ Nothing :: Maybe Number
35+ Just 2
36+
37+test4 mx my = do
38+ x <- mx
39+ y <- my
40+ Just (x + y + 1)
41+
42+test5 mx my mz = do
43+ x <- mx
44+ y <- my
45+ let sum = x + y
46+ z <- mz
47+ Just (z + sum + 1)
48+
49+test6 mx = \_ -> do
50+ let
51+ f :: forall a. Maybe a -> a
52+ f (Just x) = x
53+ Just (f mx)
54+
55+test8 = \_ -> do
56+ Just (do
57+ Just 1)
58+
59+test9 = \_ -> (+) <$> Just 1 <*> Just 2
60+
61+test10 _ = do
62+ let
63+ f x = g x * 3
64+ g x = f x / 2
65+ Just (f 10)
66+
67+main = Debug.Trace.trace "Done"
examples/passing/Dollar.pursnew file+16
@@ -0,0 +1,16 @@
1+module Main where
2+
3+import Prelude ()
4+
5+($) :: forall a b. (a -> b) -> a -> b
6+($) f x = f x
7+
8+infixr 1000 $
9+
10+id x = x
11+
12+test1 x = id $ id $ id $ id $ x
13+
14+test2 x = id id $ id x
15+
16+main = Debug.Trace.trace "Done"
examples/passing/Eff.pursnew file+19
@@ -0,0 +1,19 @@
1+module Main where
2+
3+import Prelude
4+import Control.Monad.Eff
5+import Control.Monad.ST
6+import Debug.Trace
7+
8+test1 = do
9+ trace "Line 1"
10+ trace "Line 2"
11+
12+test2 = runPure (runST (do
13+ ref <- newSTRef 0
14+ modifySTRef ref $ \n -> n + 1
15+ readSTRef ref))
16+
17+main = do
18+ test1
19+ Debug.Trace.print test2
examples/passing/EmptyDataDecls.pursnew file+30
@@ -0,0 +1,30 @@
1+module Main where
2+
3+import Prelude
4+
5+data Z
6+data S n
7+
8+data ArrayBox n a = ArrayBox [a]
9+
10+nil :: forall a. ArrayBox Z a
11+nil = ArrayBox []
12+
13+foreign import concat
14+ "function concat(l1) {\
15+ \ return function (l2) {\
16+ \ return l1.concat(l2);\
17+ \ };\
18+ \}" :: forall a. [a] -> [a] -> [a]
19+
20+cons' :: forall a n. a -> ArrayBox n a -> ArrayBox (S n) a
21+cons' x (ArrayBox xs) = ArrayBox $ concat [x] xs
22+
23+foreign import error
24+ "function error(msg) {\
25+ \ throw msg;\
26+ \}" :: forall a. String -> a
27+
28+main = case cons' 1 $ cons' 2 $ cons' 3 nil of
29+ ArrayBox [1, 2, 3] -> Debug.Trace.trace "Done"
30+ _ -> error "Failed"
examples/passing/EmptyRow.pursnew file+8
@@ -0,0 +1,8 @@
1+module Main where
2+
3+data Foo r = Foo { | r }
4+
5+test :: Foo ()
6+test = Foo {}
7+
8+main = Debug.Trace.trace "Done"
examples/passing/EmptyTypeClass.pursnew file+12
@@ -0,0 +1,12 @@
1+module Main where
2+
3+import Prelude
4+
5+class Partial
6+
7+head :: forall a. (Partial) => [a] -> a
8+head (x:xs) = x
9+
10+instance allowPartials :: Partial
11+
12+main = Debug.Trace.trace $ head ["Done"]
examples/passing/EqOrd.pursnew file+14
@@ -0,0 +1,14 @@
1+module Main where
2+
3+data Pair a b = Pair a b
4+
5+instance ordPair :: (Ord a, Ord b) => Ord (Pair a b) where
6+ compare (Pair a1 b1) (Pair a2 b2) = case compare a1 a2 of
7+ EQ -> compare b1 b2
8+ r -> r
9+
10+instance eqPair :: (Eq a, Eq b) => Eq (Pair a b) where
11+ (==) (Pair a1 b1) (Pair a2 b2) = a1 == a2 && b1 == b2
12+ (/=) (Pair a1 b1) (Pair a2 b2) = a1 /= a2 || b1 /= b2
13+
14+main = Debug.Trace.print $ Pair 1 2 == Pair 1 2
examples/passing/ExternData.pursnew file+13
@@ -0,0 +1,13 @@
1+module Main where
2+
3+ foreign import data IO :: * -> *
4+
5+ foreign import bind "function bind() {}" :: forall a b. IO a -> (a -> IO b) -> IO b
6+
7+ foreign import showMessage "function showMessage() {}" :: String -> IO { }
8+
9+ foreign import prompt "function prompt() {}" :: IO String
10+
11+ test _ = prompt `bind` \s -> showMessage s
12+
13+ main = Debug.Trace.trace "Done"
examples/passing/ExternRaw.pursnew file+13
@@ -0,0 +1,13 @@
1+module Main where
2+
3+foreign import first "function first(xs) { return xs[0]; }" :: forall a. [a] -> a
4+
5+foreign import loop "function loop() { while (true) {} }" :: forall a. a
6+
7+foreign import concat "function concat(xs) { \
8+ \ return function(ys) { \
9+ \ return xs.concat(ys); \
10+ \ };\
11+ \}" :: forall a. [a] -> [a] -> [a]
12+
13+main = Debug.Trace.trace "Done"
examples/passing/FFI.pursnew file+11
@@ -0,0 +1,11 @@
1+module Main where
2+
3+foreign import foo
4+ "function foo(s) {\
5+ \ return s;\
6+ \}" :: String -> String
7+
8+bar :: String -> String
9+bar _ = foo "test"
10+
11+main = Debug.Trace.trace "Done"
examples/passing/Fib.pursnew file+15
@@ -0,0 +1,15 @@
1+module Main where
2+
3+import Prelude
4+import Control.Monad.Eff
5+import Control.Monad.ST
6+
7+main = runST (do
8+ n1 <- newSTRef 1
9+ n2 <- newSTRef 1
10+ whileE ((>) 1000 <$> readSTRef n1) $ do
11+ n1' <- readSTRef n1
12+ n2' <- readSTRef n2
13+ writeSTRef n2 $ n1' + n2'
14+ writeSTRef n1 n2'
15+ Debug.Trace.print n2')
examples/passing/FinalTagless.pursnew file+22
@@ -0,0 +1,22 @@
1+module Main where
2+
3+import Prelude
4+
5+class E e where
6+ num :: Number -> e Number
7+ add :: e Number -> e Number -> e Number
8+
9+type Expr a = forall e. (E e) => e a
10+
11+data Id a = Id a
12+
13+instance exprId :: E Id where
14+ num = Id
15+ add (Id n) (Id m) = Id (n + m)
16+
17+runId (Id a) = a
18+
19+three :: Expr Number
20+three = add (num 1) (num 2)
21+
22+main = Debug.Trace.print $ runId three
examples/passing/ForeignInstance.pursnew file+16
@@ -0,0 +1,16 @@
1+module Main where
2+
3+class Foo a where
4+ foo :: a -> String
5+
6+foreign import instance fooArray :: (Foo a) => Foo [a]
7+
8+foreign import instance fooNumber :: Foo Number
9+
10+foreign import instance fooString :: Foo String
11+
12+test1 _ = foo [1, 2, 3]
13+
14+test2 _ = foo "Test"
15+
16+main = Debug.Trace.trace "Done"
examples/passing/FunctionScope.pursnew file+17
@@ -0,0 +1,17 @@
1+module Main where
2+
3+ import Prelude
4+
5+ mkValue :: Number -> Number
6+ mkValue id = id
7+
8+ foreign import error
9+ "function error(msg) {\
10+ \ throw msg;\
11+ \}" :: forall a. String -> a
12+
13+ main = do
14+ let value = mkValue 1
15+ if value == 1
16+ then Debug.Trace.trace "Done"
17+ else error "Not done"
examples/passing/Functions.pursnew file+15
@@ -0,0 +1,15 @@
1+module Main where
2+
3+ import Prelude
4+
5+ test1 = \_ -> 0
6+
7+ test2 = \a b -> a + b + 1
8+
9+ test3 = \a -> a
10+
11+ test4 = \(%%) -> 1 %% 2
12+
13+ test5 = \(+++) (***) -> 1 +++ 2 *** 3
14+
15+ main = Debug.Trace.trace "Done"
examples/passing/Functions2.pursnew file+17
@@ -0,0 +1,17 @@
1+module Main where
2+
3+ import Prelude
4+
5+ test :: forall a b. a -> b -> a
6+ test = \const _ -> const
7+
8+ foreign import error
9+ "function error(msg) {\
10+ \ throw msg;\
11+ \}" :: forall a. String -> a
12+
13+ main = do
14+ let value = test "Done" {}
15+ if value == "Done"
16+ then Debug.Trace.trace "Done"
17+ else error "Not done"
examples/passing/Guards.pursnew file+23
@@ -0,0 +1,23 @@
1+module Main where
2+
3+ import Prelude
4+
5+ collatz = \x -> case x of
6+ y | y % 2 == 0 -> y / 2
7+ y -> y * 3 + 1
8+
9+ -- Guards have access to current scope
10+ collatz2 = \x y -> case x of
11+ z | y > 0 -> z / 2
12+ z -> z * 3 + 1
13+
14+ min :: forall a. (Ord a) => a -> a -> a
15+ min n m | n < m = n
16+ | otherwise = m
17+
18+ max :: forall a. (Ord a) => a -> a -> a
19+ max n m = case unit of
20+ _ | m < n -> n
21+ | otherwise -> m
22+
23+ main = Debug.Trace.trace $ min "Done" "ZZZZ"
examples/passing/HoistError.pursnew file+17
@@ -0,0 +1,17 @@
1+module Main where
2+
3+import Control.Monad.Eff
4+import Debug.Trace
5+
6+foreign import f
7+ "function f(x) {\
8+ \ return function () {\
9+ \ if (x !== 0) throw new Error('x is not 0');\
10+ \ }\
11+ \}" :: forall e. Number -> Eff e Number
12+
13+main = do
14+ let x = 0
15+ f x
16+ let x = 1 + 1
17+ trace "Done"
examples/passing/IfThenElseMaybe.pursnew file+9
@@ -0,0 +1,9 @@
1+module Main where
2+
3+data Maybe a = Nothing | Just a
4+
5+test1 = if true then Just 10 else Nothing
6+
7+test2 = if true then Nothing else Just 10
8+
9+main = Debug.Trace.trace "Done"
examples/passing/ImplicitEmptyImport.pursnew file+6
@@ -0,0 +1,6 @@
1+module Main where
2+
3+main = do
4+ Debug.Trace.trace "Hello"
5+ Debug.Trace.trace "Goodbye"
6+ Debug.Trace.trace "Done"
examples/passing/ImportHiding.pursnew file+18
@@ -0,0 +1,18 @@
1+module Main where
2+
3+import Debug.Trace
4+import Prelude hiding (
5+ show, -- a value
6+ Show, -- a type class
7+ Unit(..) -- a constructor
8+ )
9+
10+show = 1
11+
12+class Show a where
13+ noshow :: a -> a
14+
15+data Unit = X | Y
16+
17+main = do
18+ print show
examples/passing/InferRecFunWithConstrainedArgument.pursnew file+8
@@ -0,0 +1,8 @@
1+module Main where
2+
3+import Prelude
4+
5+test 100 = 100
6+test n = test(1 + n)
7+
8+main = Debug.Trace.print $ test 0
examples/passing/JSReserved.pursnew file+12
@@ -0,0 +1,12 @@
1+module Main where
2+
3+ import Prelude
4+
5+ yield = 0
6+ member = 1
7+
8+ public = \return -> return
9+
10+ this catch = catch
11+
12+ main = Debug.Trace.trace "Done"
examples/passing/KindedType.pursnew file+31
@@ -0,0 +1,31 @@
1+module Main where
2+
3+type Star2Star f = f :: * -> *
4+
5+type Star t = t :: *
6+
7+test1 :: Star2Star [] String
8+test1 = ["test"]
9+
10+f :: Star (String -> String)
11+f s = s
12+
13+test2 = f "test"
14+
15+data Proxy (f :: * -> *) = Proxy
16+
17+test3 :: Proxy []
18+test3 = Proxy
19+
20+type Test (f :: * -> *) = f String
21+
22+test4 :: Test []
23+test4 = ["test"]
24+
25+class Clazz (a :: *) where
26+ def :: a
27+
28+instance clazzString :: Clazz String where
29+ def = "test"
30+
31+main = Debug.Trace.trace "Done"
examples/passing/Let.pursnew file+64
@@ -0,0 +1,64 @@
1+module Main where
2+
3+import Prelude
4+import Control.Monad.Eff
5+import Control.Monad.ST
6+
7+test1 x = let
8+ y :: Number
9+ y = x + 1
10+ in y
11+
12+test2 x y =
13+ let x' = x + 1 in
14+ let y' = y + 1 in
15+ x' + y'
16+
17+test3 = let f x y z = x + y + z in
18+ f 1 2 3
19+
20+test4 = let f x [y, z] = x y z in
21+ f (+) [1, 2]
22+
23+test5 = let
24+ f x | x > 0 = g (x / 2) + 1
25+ f x = 0
26+ g x = f (x - 1) + 1
27+ in f 10
28+
29+test6 = runPure (runST (do
30+ r <- newSTRef 0
31+ (let
32+ go [] = readSTRef r
33+ go (n : ns) = do
34+ modifySTRef r ((+) n)
35+ go ns
36+ in go [1, 2, 3, 4, 5])
37+ ))
38+
39+test7 = let
40+ f :: forall a. a -> a
41+ f x = x
42+ in if f true then f 1 else f 2
43+
44+test8 :: Number -> Number
45+test8 x = let
46+ go y | (x - 0.1 < y * y) && (y * y < x + 0.1) = y
47+ go y = go $ (y + x / y) / 2
48+ in go x
49+
50+test10 _ =
51+ let
52+ f x = g x * 3
53+ g x = f x / 2
54+ in f 10
55+
56+main = do
57+ Debug.Trace.print (test1 1)
58+ Debug.Trace.print (test2 1 2)
59+ Debug.Trace.print test3
60+ Debug.Trace.print test4
61+ Debug.Trace.print test5
62+ Debug.Trace.print test6
63+ Debug.Trace.print test7
64+ Debug.Trace.print (test8 100)
examples/passing/LetInInstance.pursnew file+12
@@ -0,0 +1,12 @@
1+module Main where
2+
3+class Foo a where
4+ foo :: a -> String
5+
6+instance fooString :: Foo String where
7+ foo = go
8+ where
9+ go :: String -> String
10+ go s = s
11+
12+main = Debug.Trace.trace "Done"
examples/passing/LiberalTypeSynonyms.pursnew file+19
@@ -0,0 +1,19 @@
1+module Main where
2+
3+type Reader = (->) String
4+
5+foo :: Reader String
6+foo s = s
7+
8+type AndFoo r = (foo :: String | r)
9+
10+getFoo :: forall r. Prim.Object (AndFoo r) -> String
11+getFoo o = o.foo
12+
13+type F r = { | r } -> { | r }
14+
15+f :: (forall r. F r) -> String
16+f g = case g { x: "Hello" } of
17+ { x = x } -> x
18+
19+main = Debug.Trace.trace "Done"
examples/passing/MPTCs.pursnew file+20
@@ -0,0 +1,20 @@
1+module Main where
2+
3+import Prelude
4+
5+class NullaryTypeClass where
6+ greeting :: String
7+
8+instance nullaryTypeClass :: NullaryTypeClass where
9+ greeting = "Hello, World!"
10+
11+class Coerce a b where
12+ coerce :: a -> b
13+
14+instance coerceRefl :: Coerce a a where
15+ coerce a = a
16+
17+instance coerceShow :: (Prelude.Show a) => Coerce a String where
18+ coerce = show
19+
20+main = Debug.Trace.trace "Done"
examples/passing/Match.pursnew file+7
@@ -0,0 +1,7 @@
1+module Main where
2+
3+ data Foo a = Foo
4+
5+ foo = \f -> case f of Foo -> "foo"
6+
7+ main = Debug.Trace.trace "Done"
examples/passing/Monad.pursnew file+32
@@ -0,0 +1,32 @@
1+module Main where
2+
3+ import Prelude ()
4+
5+ type Monad m = { return :: forall a. a -> m a
6+ , bind :: forall a b. m a -> (a -> m b) -> m b }
7+
8+ data Id a = Id a
9+
10+ id :: Monad Id
11+ id = { return : Id
12+ , bind : \ma f -> case ma of Id a -> f a }
13+
14+ data Maybe a = Nothing | Just a
15+
16+ maybe :: Monad Maybe
17+ maybe = { return : Just
18+ , bind : \ma f -> case ma of
19+ Nothing -> Nothing
20+ Just a -> f a
21+ }
22+
23+ test :: forall m. Monad m -> m Number
24+ test = \m -> m.bind (m.return 1) (\n1 ->
25+ m.bind (m.return "Test") (\n2 ->
26+ m.return n1))
27+
28+ test1 = test id
29+
30+ test2 = test maybe
31+
32+ main = Debug.Trace.trace "Done"
examples/passing/MonadState.pursnew file+48
@@ -0,0 +1,48 @@
1+module Main where
2+
3+import Prelude
4+
5+data Tuple a b = Tuple a b
6+
7+class MonadState s m where
8+ get :: m s
9+ put :: s -> m {}
10+
11+data State s a = State (s -> Tuple s a)
12+
13+runState s (State f) = f s
14+
15+instance functorState :: Functor (State s) where
16+ (<$>) = liftM1
17+
18+instance applyState :: Apply (State s) where
19+ (<*>) = ap
20+
21+instance applicativeState :: Applicative (State s) where
22+ pure a = State $ \s -> Tuple s a
23+
24+instance bindState :: Bind (State s) where
25+ (>>=) f g = State $ \s -> case runState s f of
26+ Tuple s1 a -> runState s1 (g a)
27+
28+instance monadState :: Monad (State s)
29+
30+instance monadStateState :: MonadState s (State s) where
31+ get = State (\s -> Tuple s s)
32+ put s = State (\_ -> Tuple s {})
33+
34+modify :: forall m s. (Prelude.Monad m, MonadState s m) => (s -> s) -> m {}
35+modify f = do
36+ s <- get
37+ put (f s)
38+
39+test :: Tuple String String
40+test = runState "" $ do
41+ modify $ (++) "World!"
42+ modify $ (++) "Hello, "
43+ get
44+
45+main = do
46+ let t1 = test
47+ Debug.Trace.trace "Done"
48+
examples/passing/MultiArgFunctions.pursnew file+26
@@ -0,0 +1,26 @@
1+module Main where
2+
3+import Data.Function
4+import Control.Monad.Eff
5+import Debug.Trace
6+
7+f = mkFn2 $ \a b -> runFn2 g a b + runFn2 g b a
8+
9+g = mkFn2 $ \a b -> case {} of
10+ _ | a <= 0 || b <= 0 -> b
11+ _ -> runFn2 f (a - 1) (b - 1)
12+
13+main = do
14+ runFn0 (mkFn0 $ \_ -> trace $ show 0)
15+ runFn1 (mkFn1 $ \a -> trace $ show a) 1
16+ runFn2 (mkFn2 $ \a b -> trace $ show [a, b]) 1 2
17+ runFn3 (mkFn3 $ \a b c -> trace $ show [a, b, c]) 1 2 3
18+ runFn4 (mkFn4 $ \a b c d -> trace $ show [a, b, c, d]) 1 2 3 4
19+ runFn5 (mkFn5 $ \a b c d e -> trace $ show [a, b, c, d, e]) 1 2 3 4 5
20+ runFn6 (mkFn6 $ \a b c d e f -> trace $ show [a, b, c, d, e, f]) 1 2 3 4 5 6
21+ runFn7 (mkFn7 $ \a b c d e f g -> trace $ show [a, b, c, d, e, f, g]) 1 2 3 4 5 6 7
22+ runFn8 (mkFn8 $ \a b c d e f g h -> trace $ show [a, b, c, d, e, f, g, h]) 1 2 3 4 5 6 7 8
23+ runFn9 (mkFn9 $ \a b c d e f g h i -> trace $ show [a, b, c, d, e, f, g, h, i]) 1 2 3 4 5 6 7 8 9
24+ runFn10 (mkFn10 $ \a b c d e f g h i j-> trace $ show [a, b, c, d, e, f, g, h, i, j]) 1 2 3 4 5 6 7 8 9 10
25+ print $ runFn2 g 15 12
26+ trace "Done!"
examples/passing/MultipleConstructorArgs.pursnew file+21
@@ -0,0 +1,21 @@
1+module Main where
2+
3+import Prelude
4+import Control.Monad.Eff
5+
6+data P a b = P a b
7+
8+runP :: forall a b r. (a -> b -> r) -> P a b -> r
9+runP f (P a b) = f a b
10+
11+idP = runP P
12+
13+testCase = \p -> case p of
14+ P (x:xs) (y:ys) -> x + y
15+ P _ _ -> 0
16+
17+test1 = testCase (P [1, 2, 3] [4, 5, 6])
18+
19+main = do
20+ Debug.Trace.trace (runP (\s n -> s ++ show n) (P "Test" 1))
21+ Debug.Trace.print test1
examples/passing/MutRec.pursnew file+19
@@ -0,0 +1,19 @@
1+module Main where
2+
3+ import Prelude
4+
5+ f 0 = 0
6+ f x = g x + 1
7+
8+ g x = f (x / 2)
9+
10+ data Even = Zero | Even Odd
11+
12+ data Odd = Odd Even
13+
14+ evenToNumber Zero = 0
15+ evenToNumber (Even n) = oddToNumber n + 1
16+
17+ oddToNumber (Odd n) = evenToNumber n + 1
18+
19+ main = Debug.Trace.trace "Done"
examples/passing/MutRec2.pursnew file+17
@@ -0,0 +1,17 @@
1+module Main where
2+
3+data A = A B
4+
5+data B = B A
6+
7+foreign import data S :: *
8+
9+f :: A -> S
10+f a = case a of A b -> g b
11+
12+g b = case b of B a -> f a
13+
14+showN :: A -> S
15+showN a = f a
16+
17+main = Debug.Trace.trace "Done"
examples/passing/MutRec3.pursnew file+17
@@ -0,0 +1,17 @@
1+module Main where
2+
3+data A = A B
4+
5+data B = B A
6+
7+foreign import data S :: *
8+
9+f a = case a of A b -> g b
10+
11+g :: B -> S
12+g b = case b of B a -> f a
13+
14+showN :: A -> S
15+showN a = f a
16+
17+main = Debug.Trace.trace "Done"
examples/passing/NamedPatterns.pursnew file+7
@@ -0,0 +1,7 @@
1+module Main where
2+
3+ foo = \x -> case x of
4+ y@{ foo = "Foo" } -> y
5+ y -> y
6+
7+ main = Debug.Trace.trace "Done"
examples/passing/NegativeBinder.pursnew file+7
@@ -0,0 +1,7 @@
1+module Main where
2+
3+test :: Number -> Boolean
4+test -1 = false
5+test _ = true
6+
7+main = Debug.Trace.trace "Done"
examples/passing/Nested.pursnew file+7
@@ -0,0 +1,7 @@
1+module Main where
2+
3+ data Extend r a = Extend { prev :: r a, next :: a }
4+
5+ data Matrix r a = Square (r (r a)) | Bigger (Matrix (Extend r) a)
6+
7+ main = Debug.Trace.trace "Done"
examples/passing/NestedTypeSynonyms.pursnew file+11
@@ -0,0 +1,11 @@
1+module Main where
2+
3+ import Prelude
4+
5+ type X = String
6+ type Y = X -> X
7+
8+ fn :: Y
9+ fn a = a
10+
11+ main = Debug.Trace.print (fn "Done")
examples/passing/Newtype.pursnew file+22
@@ -0,0 +1,22 @@
1+module Main where
2+
3+import Control.Monad.Eff
4+import Debug.Trace
5+
6+newtype Thing = Thing String
7+
8+instance showThing :: Show Thing where
9+ show (Thing x) = "Thing " ++ show x
10+
11+newtype Box a = Box a
12+
13+instance showBox :: (Show a) => Show (Box a) where
14+ show (Box x) = "Box " ++ show x
15+
16+apply f x = f x
17+
18+main = do
19+ print $ Thing "hello"
20+ print $ Box 42
21+ print $ apply Box 9000
22+ trace "Done"
examples/passing/NewtypeEff.pursnew file+28
@@ -0,0 +1,28 @@
1+module Main where
2+
3+import Debug.Trace
4+import Control.Monad.Eff
5+
6+newtype T a = T (Eff (trace :: Trace) a)
7+
8+runT :: forall a. T a -> Eff (trace :: Trace) a
9+runT (T t) = t
10+
11+instance functorT :: Functor T where
12+ (<$>) f (T t) = T (f <$> t)
13+
14+instance applyT :: Apply T where
15+ (<*>) (T f) (T x) = T (f <*> x)
16+
17+instance applicativeT :: Applicative T where
18+ pure t = T (pure t)
19+
20+instance bindT :: Bind T where
21+ (>>=) (T t) f = T (t >>= \x -> runT (f x))
22+
23+instance monadT :: Monad T
24+
25+main = runT do
26+ T $ trace "Done"
27+ T $ trace "Done"
28+ T $ trace "Done"
examples/passing/ObjectSynonym.pursnew file+13
@@ -0,0 +1,13 @@
1+module Main where
2+
3+type Inner = Number
4+
5+inner :: Inner
6+inner = 0
7+
8+type Outer = { inner :: Inner }
9+
10+outer :: Outer
11+outer = { inner: inner }
12+
13+main = Debug.Trace.trace "Done"
examples/passing/ObjectUpdate.pursnew file+18
@@ -0,0 +1,18 @@
1+module Main where
2+
3+ update1 = \o -> o { foo = "Foo" }
4+
5+ update2 :: forall r. { foo :: String | r } -> { foo :: String | r }
6+ update2 = \o -> o { foo = "Foo" }
7+
8+ replace = \o -> case o of
9+ { foo = "Foo" } -> o { foo = "Bar" }
10+ { foo = "Bar" } -> o { bar = "Baz" }
11+ o -> o
12+
13+ polyUpdate :: forall a r. { foo :: a | r } -> { foo :: String | r }
14+ polyUpdate = \o -> o { foo = "Foo" }
15+
16+ inferPolyUpdate = \o -> o { foo = "Foo" }
17+
18+ main = Debug.Trace.trace ((update1 {foo: ""}).foo)
examples/passing/ObjectUpdate2.pursnew file+14
@@ -0,0 +1,14 @@
1+module Main where
2+
3+type X r = { | r }
4+
5+foreign import x "var x = {};" :: forall r. X r
6+
7+blah :: forall r. X r -> X r
8+blah x = x
9+
10+test = blah x
11+ { baz = "blah"
12+ }
13+
14+main = Debug.Trace.trace "Done"
examples/passing/Objects.pursnew file+30
@@ -0,0 +1,30 @@
1+module Main where
2+
3+ import Prelude
4+
5+ test = \x -> x.foo + x.bar + 1
6+
7+ append = \o -> { foo: o.foo, bar: 1 }
8+
9+ apTest = append({foo : "Foo", baz: "Baz"})
10+
11+ f = (\a -> a.b.c) { b: { c: 1, d: "Hello" }, e: "World" }
12+
13+ g = (\a -> a.f { x: 1, y: "y" }) { f: \o -> o.x + 1 }
14+
15+ typed :: { foo :: Number }
16+ typed = { foo: 0 }
17+
18+ test2 = \x -> x."!@#"
19+
20+ test3 = typed."foo"
21+
22+ test4 = test2 weirdObj
23+ where
24+ weirdObj :: { "!@#" :: Number }
25+ weirdObj = { "!@#": 1 }
26+
27+ test5 = case { "***": 1 } of
28+ { "***" = n } -> n
29+
30+ main = Debug.Trace.trace "Done"
examples/passing/OneConstructor.pursnew file+7
@@ -0,0 +1,7 @@
1+module Main where
2+
3+data One a = One a
4+
5+one (One a) = a
6+
7+main = Debug.Trace.trace "Done"
examples/passing/OperatorAssociativity.pursnew file+15
@@ -0,0 +1,15 @@
1+module Main where
2+
3+import Control.Monad.Eff
4+
5+bug :: Number -> Number -> Number
6+bug a b = 0 - (a - b)
7+
8+foreign import explode
9+ "function explode() {\
10+ \ throw new Error('Assertion failed!');\
11+ \}":: forall eff a. Eff eff a
12+
13+main = case bug 0 2 of
14+ 2 -> Debug.Trace.trace "Done!"
15+ _ -> explode
examples/passing/Operators.pursnew file+80
@@ -0,0 +1,80 @@
1+module Main where
2+
3+ import Control.Monad.Eff
4+ import Debug.Trace
5+
6+ (?!) :: forall a. a -> a -> a
7+ (?!) x _ = x
8+
9+ bar :: String -> String -> String
10+ bar = \s1 s2 -> s1 ++ s2
11+
12+ test1 :: forall n. (Num n) => n -> n -> (n -> n -> n) -> n
13+ test1 x y z = x * y + z x y
14+
15+ test2 = (\x -> x.foo false) { foo : \_ -> 1 }
16+
17+ test3 = (\x y -> x)(1 + 2 * (1 + 2)) (true && (false || false))
18+
19+ k = \x -> \y -> x
20+
21+ test4 = 1 `k` 2
22+
23+ infixl 5 %%
24+
25+ (%%) :: Number -> Number -> Number
26+ (%%) x y = x * y + y
27+
28+ test5 = 1 %% 2 %% 3
29+
30+ test6 = ((\x -> x) `k` 2) 3
31+
32+ (<+>) :: String -> String -> String
33+ (<+>) = \s1 s2 -> s1 ++ s2
34+
35+ test7 = "Hello" <+> "World!"
36+
37+ (@@) :: forall a b. (a -> b) -> a -> b
38+ (@@) = \f x -> f x
39+
40+ foo :: String -> String
41+ foo = \s -> s
42+
43+ test8 = foo @@ "Hello World"
44+
45+ test9 = Main.foo @@ "Hello World"
46+
47+ test10 = "Hello" `Main.bar` "World"
48+
49+ (...) :: forall a. [a] -> [a] -> [a]
50+ (...) = \as -> \bs -> as
51+
52+ test11 = [1, 2, 3] ... [4, 5, 6]
53+
54+ test12 (<%>) a b = a <%> b
55+
56+ test13 = \(<%>) a b -> a <%> b
57+
58+ test14 :: Number -> Number -> Boolean
59+ test14 a b = a < b
60+
61+ test15 :: Number -> Number -> Boolean
62+ test15 a b = const false $ a `test14` b
63+
64+ main = do
65+ let t1 = test1 1 2 (\x y -> x + y)
66+ let t2 = test2
67+ let t3 = test3
68+ let t4 = test4
69+ let t5 = test5
70+ let t6 = test6
71+ let t7 = test7
72+ let t8 = test8
73+ let t9 = test9
74+ let t10 = test10
75+ let t11 = test11
76+ let t12 = test12 k 1 2
77+ let t13 = test13 k 1 2
78+ let t14 = test14 1 2
79+ let t15 = test15 1 2
80+ trace "Done"
examples/passing/OptimizerBug.pursnew file+9
@@ -0,0 +1,9 @@
1+module Main where
2+
3+import Prelude
4+
5+x a = 1 + y a
6+
7+y a = x a
8+
9+main = Debug.Trace.trace "Done"
examples/passing/PartialFunction.pursnew file+17
@@ -0,0 +1,17 @@
1+module Main where
2+
3+foreign import testError
4+ "function testError(f) {\
5+ \ try {\
6+ \ return f();\
7+ \ } catch (e) {\
8+ \ if (e instanceof Error) return 'success';\
9+ \ throw new Error('Pattern match failure is not Error');\
10+ \ }\
11+ \}" :: (Unit -> Number) -> String
12+
13+fn :: Number -> Number
14+fn 0 = 0
15+fn 1 = 2
16+
17+main = Debug.Trace.trace (show $ testError $ \_ -> fn 2)
examples/passing/Patterns.pursnew file+28
@@ -0,0 +1,28 @@
1+module Main where
2+
3+ import Prelude
4+
5+ test = \x -> case x of
6+ { str = "Foo", bool = true } -> true
7+ { str = "Bar", bool = b } -> b
8+ _ -> false
9+
10+ f = \o -> case o of
11+ { foo = "Foo" } -> o.bar
12+ _ -> 0
13+
14+ g = \o -> case o of
15+ { arr = [x : xs], take = "car" } -> x
16+ { arr = [_, x : xs], take = "cadr" } -> x
17+ _ -> 0
18+
19+
20+ h = \o -> case o of
21+ a@[_,_,_] -> a
22+ _ -> []
23+
24+ isDesc :: [Number] -> Boolean
25+ isDesc [x, y] | x > y = true
26+ isDesc _ = false
27+
28+ main = Debug.Trace.trace "Done"
examples/passing/Person.pursnew file+16
@@ -0,0 +1,16 @@
1+module Main where
2+
3+ import Prelude ((++))
4+
5+ data Person = Person { name :: String, age :: Number }
6+
7+ foreign import itoa
8+ "function itoa(n) {\
9+ \ return n.toString();\
10+ \}" :: Number -> String
11+
12+ showPerson :: Person -> String
13+ showPerson = \p -> case p of
14+ Person o -> o.name ++ ", aged " ++ itoa(o.age)
15+
16+ main = Debug.Trace.trace "Done"
examples/passing/Rank2Data.pursnew file+29
@@ -0,0 +1,29 @@
1+module Main where
2+
3+ import Prelude
4+
5+ data Id = Id forall a. a -> a
6+
7+ runId = \id a -> case id of
8+ Id f -> f a
9+
10+ data Nat = Nat forall r. r -> (r -> r) -> r
11+
12+ runNat = \nat -> case nat of
13+ Nat f -> f 0 (\n -> n + 1)
14+
15+ zero = Nat (\zero _ -> zero)
16+
17+ succ = \n -> case n of
18+ Nat f -> Nat (\zero succ -> succ (f zero succ))
19+
20+ add = \n m -> case n of
21+ Nat f -> case m of
22+ Nat g -> Nat (\zero succ -> g (f zero succ) succ)
23+
24+ one = succ zero
25+ two = succ zero
26+ four = add two two
27+ fourNumber = runNat four
28+
29+ main = Debug.Trace.trace "Done"
examples/passing/Rank2Object.pursnew file+10
@@ -0,0 +1,10 @@
1+module Main where
2+
3+import Debug.Trace
4+
5+data Foo = Foo { id :: forall a. a -> a }
6+
7+foo :: Foo -> Number
8+foo (Foo { id = f }) = f 0
9+
10+main = trace "Done"
examples/passing/Rank2TypeSynonym.pursnew file+15
@@ -0,0 +1,15 @@
1+module Main where
2+
3+import Control.Monad.Eff
4+
5+type Foo a = forall f. (Monad f) => f a
6+
7+foo :: forall a. a -> Foo a
8+foo x = pure x
9+
10+bar :: Foo Number
11+bar = foo 3
12+
13+main = do
14+ x <- bar
15+ Debug.Trace.print x
examples/passing/Rank2Types.pursnew file+11
@@ -0,0 +1,11 @@
1+module Main where
2+
3+ import Prelude
4+
5+ test1 :: (forall a. (a -> a)) -> Number
6+ test1 = \f -> f 0
7+
8+ forever :: forall m a b. (forall a b. m a -> (a -> m b) -> m b) -> m a -> m b
9+ forever = \bind action -> bind action $ \_ -> forever bind action
10+
11+ main = Debug.Trace.trace "Done"
examples/passing/Recursion.pursnew file+10
@@ -0,0 +1,10 @@
1+module Main where
2+
3+ import Prelude
4+
5+ fib = \n -> case n of
6+ 0 -> 1
7+ 1 -> 1
8+ n -> fib (n - 1) + fib (n - 2)
9+
10+ main = Debug.Trace.trace "Done"
examples/passing/ReservedWords.pursnew file+13
@@ -0,0 +1,13 @@
1+-- See https://github.com/purescript/purescript/issues/606
2+module Main where
3+
4+ o :: { type :: String }
5+ o = { type: "o" }
6+
7+ p :: { type :: String }
8+ p = o { type = "p" }
9+
10+ f :: forall r. { type :: String | r } -> String
11+ f { type = "p" } = "Done"
12+
13+ main = Debug.Trace.trace $ f { type: p.type, foo: "bar" }
examples/passing/RuntimeScopeIssue.pursnew file+19
@@ -0,0 +1,19 @@
1+module Main where
2+
3+import Prelude
4+
5+class A a where
6+ a :: a -> Boolean
7+
8+class B a where
9+ b :: a -> Boolean
10+
11+instance aNumber :: A Number where
12+ a 0 = true
13+ a n = b (n - 1)
14+
15+instance bNumber :: B Number where
16+ b 0 = false
17+ b n = a (n - 1)
18+
19+main = Debug.Trace.print $ a 10
examples/passing/STArray.pursnew file+25
@@ -0,0 +1,25 @@
1+module Main where
2+
3+import Prelude
4+import Control.Monad.Eff
5+import Control.Monad.ST
6+import Debug.Trace
7+
8+test = runSTArray (do
9+ a <- newSTArray 2 0
10+ pokeSTArray a 0 1
11+ pokeSTArray a 1 2
12+ return a)
13+
14+fromTo lo hi = runSTArray (do
15+ arr <- newSTArray (hi - lo + 1) 0
16+ (let
17+ go lo hi _ arr | lo > hi = return arr
18+ go lo hi i arr = do
19+ pokeSTArray arr i lo
20+ go (lo + 1) hi (i + 1) arr
21+ in go lo hi 0 arr))
22+
23+main = do
24+ let t1 = runPure (fromTo 10 20)
25+ trace "Done"
examples/passing/Sequence.pursnew file+12
@@ -0,0 +1,12 @@
1+module Main where
2+
3+import Control.Monad.Eff
4+
5+class Sequence t where
6+ sequence :: forall m a. (Monad m) => t (m a) -> m (t a)
7+
8+instance sequenceArray :: Sequence [] where
9+ sequence [] = pure []
10+ sequence (x:xs) = (:) <$> x <*> sequence xs
11+
12+main = sequence $ [Debug.Trace.trace "Done"]
examples/passing/ShadowedRename.pursnew file+19
@@ -0,0 +1,19 @@
1+module Main where
2+
3+import Control.Monad.Eff
4+import Debug.Trace
5+
6+foreign import f
7+ "function f(x) {\
8+ \ return function () {\
9+ \ if (x !== 2) throw new Error('x is not 2');\
10+ \ }\
11+ \}" :: forall e. Number -> Eff e Number
12+
13+foo foo = let foo_1 = \_ -> foo
14+ foo_2 = foo_1 unit + 1
15+ in foo_2
16+
17+main = do
18+ f (foo 1)
19+ trace "Done"
examples/passing/ShadowedTCO.pursnew file+16
@@ -0,0 +1,16 @@
1+module Main where
2+
3+runNat f = f 0 (\n -> n + 1)
4+
5+zero z _ = z
6+
7+succ f zero succ = succ (f zero succ)
8+
9+add f g zero succ = g (f zero succ) succ
10+
11+one = succ zero
12+two = succ one
13+four = add two two
14+fourNumber = runNat four
15+
16+main = Debug.Trace.trace $ show fourNumber
examples/passing/ShadowedTCOLet.pursnew file+7
@@ -0,0 +1,7 @@
1+module Main where
2+
3+f x y z =
4+ let f 1 2 3 = 1
5+ in f x z y
6+
7+main = Debug.Trace.trace $ show $ f 1 3 2
examples/passing/SignedNumericLiterals.pursnew file+15
@@ -0,0 +1,15 @@
1+module Main where
2+
3+ p = 0.5
4+ q = 1
5+ x = -1
6+ y = -0.5
7+ z = 0.5
8+ w = 1
9+
10+ f :: Number -> Number
11+ f x = -x
12+
13+ test1 = 2 - 1
14+
15+ main = Debug.Trace.trace "Done"
examples/passing/Superclasses1.pursnew file+18
@@ -0,0 +1,18 @@
1+module Main where
2+
3+class Su a where
4+ su :: a -> a
5+
6+class (Su a) <= Cl a where
7+ cl :: a -> a -> a
8+
9+instance suNumber :: Su Number where
10+ su n = n + 1
11+
12+instance clNumber :: Cl Number where
13+ cl n m = n + m
14+
15+test :: forall a. (Cl a) => a -> a
16+test a = su (cl a a)
17+
18+main = Debug.Trace.print $ test 10
examples/passing/Superclasses2.pursnew file+23
@@ -0,0 +1,23 @@
1+module Main where
2+
3+import Prelude.Unsafe (unsafeIndex)
4+
5+class Su a where
6+ su :: a -> a
7+
8+class (Su [a]) <= Cl a where
9+ cl :: a -> a -> a
10+
11+instance suNumber :: Su Number where
12+ su n = n + 1
13+
14+instance suArray :: (Su a) => Su [a] where
15+ su (x : _) = [su x]
16+
17+instance clNumber :: Cl Number where
18+ cl n m = n + m
19+
20+test :: forall a. (Cl a) => a -> [a]
21+test x = su [cl x x]
22+
23+main = Debug.Trace.print $ test 10 `unsafeIndex` 0
examples/passing/Superclasses3.pursnew file+41
@@ -0,0 +1,41 @@
1+module Main where
2+
3+import Debug.Trace
4+
5+import Control.Monad.Eff
6+
7+class (Monad m) <= MonadWriter w m where
8+ tell :: w -> m Unit
9+
10+testFunctor :: forall m. (Monad m) => m Number -> m Number
11+testFunctor n = (+) 1 <$> n
12+
13+test :: forall w m. (Monad m, MonadWriter w m) => w -> m Unit
14+test w = do
15+ tell w
16+ tell w
17+ tell w
18+
19+data MTrace a = MTrace (Eff (trace :: Trace) a)
20+
21+runMTrace :: forall a. MTrace a -> Eff (trace :: Trace) a
22+runMTrace (MTrace a) = a
23+
24+instance functorMTrace :: Functor MTrace where
25+ (<$>) = liftM1
26+
27+instance applyMTrace :: Apply MTrace where
28+ (<*>) = ap
29+
30+instance applicativeMTrace :: Applicative MTrace where
31+ pure = MTrace <<< return
32+
33+instance bindMTrace :: Bind MTrace where
34+ (>>=) m f = MTrace (runMTrace m >>= (runMTrace <<< f))
35+
36+instance monadMTrace :: Monad MTrace
37+
38+instance writerMTrace :: MonadWriter String MTrace where
39+ tell s = MTrace (trace s)
40+
41+main = runMTrace $ test "Done"
examples/passing/TCOCase.pursnew file+10
@@ -0,0 +1,10 @@
1+module Main where
2+
3+data Data = One | More Data
4+
5+main = Debug.Trace.trace (from (to 10000 One))
6+ where
7+ to 0 a = a
8+ to n a = to (n - 1) (More a)
9+ from One = "Done"
10+ from (More d) = from d
examples/passing/TailCall.pursnew file+15
@@ -0,0 +1,15 @@
1+module Main where
2+
3+import Prelude
4+
5+test :: Number -> [Number] -> Number
6+test n [] = n
7+test n (x:xs) = test (n + x) xs
8+
9+loop :: forall a. Number -> a
10+loop x = loop (x + 1)
11+
12+notATailCall = \x ->
13+ (\notATailCall -> notATailCall x) (\x -> x)
14+
15+main = Debug.Trace.print (test 0 [1, 2, 3])
examples/passing/Tick.pursnew file+5
@@ -0,0 +1,5 @@
1+module Main where
2+
3+test' x = x
4+
5+main = Debug.Trace.trace "Done"
examples/passing/TopLevelCase.pursnew file+18
@@ -0,0 +1,18 @@
1+module Main where
2+
3+ import Prelude
4+
5+ gcd :: Number -> Number -> Number
6+ gcd 0 x = x
7+ gcd x 0 = x
8+ gcd x y | x > y = gcd (x % y) y
9+ gcd x y = gcd (y % x) x
10+
11+ guardsTest (x:xs) | x > 0 = guardsTest xs
12+ guardsTest xs = xs
13+
14+ data A = A
15+
16+ parseTest A 0 = 0
17+
18+ main = Debug.Trace.trace "Done"
examples/passing/TypeClassImport.pursnew file+18
@@ -0,0 +1,18 @@
1+module Main where
2+
3+foreign import data T :: *
4+
5+foreign import data C :: *
6+
7+foreign import t "var t = null;" :: T
8+
9+foreign import inst """
10+ var inst = {
11+ show: function(t) {
12+ return 'Done';
13+ }
14+ }""" :: C
15+
16+foreign import instance inst :: Show T
17+
18+main = Debug.Trace.print t
examples/passing/TypeClassMemberOrderChange.pursnew file+11
@@ -0,0 +1,11 @@
1+module Main where
2+
3+class Test a where
4+ fn :: a -> a -> a
5+ val :: a
6+
7+instance testBoolean :: Test Boolean where
8+ val = true
9+ fn x y = y
10+
11+main = Debug.Trace.trace (show (fn true val))
examples/passing/TypeClasses.pursnew file+69
@@ -0,0 +1,69 @@
1+module Main where
2+
3+import Prelude
4+
5+test1 = \_ -> show "testing"
6+
7+f :: forall a. (Prelude.Show a) => a -> String
8+f x = show x
9+
10+test2 = \_ -> f "testing"
11+
12+test7 :: forall a. (Prelude.Show a) => a -> String
13+test7 = show
14+
15+test8 = \_ -> show $ "testing"
16+
17+data Data a = Data a
18+
19+instance showData :: (Prelude.Show a) => Prelude.Show (Data a) where
20+ show (Data a) = "Data (" ++ show a ++ ")"
21+
22+test3 = \_ -> show (Data "testing")
23+
24+instance functorData :: Functor Data where
25+ (<$>) = liftM1
26+
27+instance applyData :: Apply Data where
28+ (<*>) = ap
29+
30+instance applicativeData :: Applicative Data where
31+ pure = Data
32+
33+instance bindData :: Bind Data where
34+ (>>=) (Data a) f = f a
35+
36+instance monadData :: Monad Data
37+
38+data Maybe a = Nothing | Just a
39+
40+instance functorMaybe :: Functor Maybe where
41+ (<$>) = liftM1
42+
43+instance applyMaybe :: Apply Maybe where
44+ (<*>) = ap
45+
46+instance applicativeMaybe :: Applicative Maybe where
47+ pure = Just
48+
49+instance bindMaybe :: Bind Maybe where
50+ (>>=) Nothing _ = Nothing
51+ (>>=) (Just a) f = f a
52+
53+instance monadMaybe :: Monad Maybe
54+
55+test4 :: forall a m. (Monad m) => a -> m Number
56+test4 = \_ -> return 1
57+
58+test5 = \_ -> Just 1 >>= \n -> return (n + 1)
59+
60+ask r = r
61+
62+runReader r f = f r
63+
64+test9 _ = runReader 0 $ do
65+ n <- ask
66+ return $ n + 1
67+
68+main = Debug.Trace.trace (test7 "Done")
69+
examples/passing/TypeClassesInOrder.pursnew file+11
@@ -0,0 +1,11 @@
1+module Main where
2+
3+import Prelude
4+
5+class Foo a where
6+ foo :: a -> String
7+
8+instance fooString :: Foo String where
9+ foo s = s
10+
11+main = Debug.Trace.trace $ foo "Done"
examples/passing/TypeClassesWithOverlappingTypeVariables.pursnew file+11
@@ -0,0 +1,11 @@
1+module Main where
2+
3+ import Prelude
4+
5+ data Either a b = Left a | Right b
6+
7+ instance functorEither :: Prelude.Functor (Either a) where
8+ (<$>) _ (Left x) = Left x
9+ (<$>) f (Right y) = Right (f y)
10+
11+ main = Debug.Trace.trace "Done"
examples/passing/TypeDecl.pursnew file+12
@@ -0,0 +1,12 @@
1+module Main where
2+
3+ import Prelude
4+
5+ k :: String -> Number -> String
6+ k x y = x
7+
8+ iterate :: forall a. Number -> (a -> a) -> a -> a
9+ iterate 0 f a = a
10+ iterate n f a = iterate (n - 1) f (f a)
11+
12+ main = Debug.Trace.trace "Done"
examples/passing/TypeSynonymInData.pursnew file+9
@@ -0,0 +1,9 @@
1+module Main where
2+
3+type A a = [a]
4+
5+data Foo a = Foo (A a) | Bar
6+
7+foo (Foo []) = Bar
8+
9+main = Debug.Trace.trace "Done"
examples/passing/TypeSynonyms.pursnew file+25
@@ -0,0 +1,25 @@
1+module Main where
2+
3+ type Lens a b =
4+ { get :: a -> b
5+ , set :: a -> b -> a
6+ }
7+
8+ composeLenses :: forall a b c. Lens a b -> Lens b c -> Lens a c
9+ composeLenses = \l1 -> \l2 ->
10+ { get: \a -> l2.get (l1.get a)
11+ , set: \a c -> l1.set a (l2.set (l1.get a) c)
12+ }
13+
14+ type Pair a b = { fst :: a, snd :: b }
15+
16+ fst :: forall a b. Lens (Pair a b) a
17+ fst =
18+ { get: \p -> p.fst
19+ , set: \p a -> { fst: a, snd: p.snd }
20+ }
21+
22+ test1 :: forall a b c. Lens (Pair (Pair a b) c) a
23+ test1 = composeLenses fst fst
24+
25+ main = Debug.Trace.trace "Done"
examples/passing/TypeWildcards.pursnew file+10
@@ -0,0 +1,10 @@
1+module Main where
2+
3+test :: forall a. (Eq a) => (a -> a) -> a -> a
4+test f a = go (f a) a
5+ where
6+ go :: _ -> _ -> _
7+ go a1 a2 | a1 == a2 = a1
8+ go a1 _ = go (f a1) a1
9+
10+main = Debug.Trace.trace "Done"
examples/passing/TypedWhere.pursnew file+13
@@ -0,0 +1,13 @@
1+module Main where
2+
3+data E a b = L a | R b
4+
5+lefts :: forall a b. [E a b] -> [a]
6+lefts = go []
7+ where
8+ go :: forall a b. [a] -> [E a b] -> [a]
9+ go ls [] = ls
10+ go ls (L a : rest) = go (a : ls) rest
11+ go ls (_ : rest) = go ls rest
12+
13+main = Debug.Trace.trace "Done"
examples/passing/Unit.pursnew file+6
@@ -0,0 +1,6 @@
1+module Main where
2+
3+import Prelude
4+import Debug.Trace
5+
6+main = print (const unit $ "Hello world")
examples/passing/UnknownInTypeClassLookup.pursnew file+12
@@ -0,0 +1,12 @@
1+module Main where
2+
3+class EQ a b
4+
5+instance eqAA :: EQ a a
6+
7+test :: forall a b. (EQ a b) => a -> b -> String
8+test _ _ = "Done"
9+
10+runTest a = test a a
11+
12+main = Debug.Trace.trace $ runTest 0
examples/passing/Where.pursnew file+49
@@ -0,0 +1,49 @@
1+module Main where
2+
3+import Prelude
4+import Control.Monad.Eff
5+import Control.Monad.ST
6+
7+test1 x = y
8+ where
9+ y :: Number
10+ y = x + 1
11+
12+test2 x y = x' + y'
13+ where
14+ x' = x + 1
15+ y' = y + 1
16+
17+
18+test3 = f 1 2 3
19+ where f x y z = x + y + z
20+
21+
22+test4 = f (+) [1, 2]
23+ where f x [y, z] = x y z
24+
25+
26+test5 = g 10
27+ where
28+ f x | x > 0 = g (x / 2) + 1
29+ f x = 0
30+ g x = f (x - 1) + 1
31+
32+test6 = if f true then f 1 else f 2
33+ where f :: forall a. a -> a
34+ f x = x
35+
36+test7 :: Number -> Number
37+test7 x = go x
38+ where
39+ go y | (x - 0.1 < y * y) && (y * y < x + 0.1) = y
40+ go y = go $ (y + x / y) / 2
41+
42+main = do
43+ Debug.Trace.print (test1 1)
44+ Debug.Trace.print (test2 1 2)
45+ Debug.Trace.print test3
46+ Debug.Trace.print test4
47+ Debug.Trace.print test5
48+ Debug.Trace.print test6
49+ Debug.Trace.print (test7 100)
examples/passing/iota.pursnew file+9
@@ -0,0 +1,9 @@
1+module Main where
2+
3+ s = \x -> \y -> \z -> x z (y z)
4+
5+ k = \x -> \y -> x
6+
7+ iota = \x -> x s k
8+
9+ main = Debug.Trace.trace "Done"
examples/passing/s.pursnew file+5
@@ -0,0 +1,5 @@
1+module Main where
2+
3+ s = \x y z -> x z (y z)
4+
5+ main = Debug.Trace.trace "Done"
hierarchy/Main.hsnew file+104
@@ -0,0 +1,104 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Main
4+-- Copyright : (c) Hardy Jones 2014
5+-- License : MIT
6+--
7+-- Maintainer : Hardy Jones <jones3.hardy@gmail.com>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- Generate Directed Graphs of PureScript TypeClasses
13+--
14+-----------------------------------------------------------------------------
15+
16+module Main where
17+
18+import Control.Applicative ((<*>), (<$>))
19+import Control.Monad (unless)
20+
21+import Data.List (intercalate,nub,sort)
22+import Data.Foldable (for_)
23+import Data.Version (showVersion)
24+
25+import System.Console.CmdTheLine
26+import System.Directory (createDirectoryIfMissing)
27+import System.FilePath ((</>))
28+import System.Exit (exitFailure, exitSuccess)
29+import System.IO (stderr)
30+
31+import Text.Parsec (ParseError)
32+
33+import qualified Language.PureScript as P
34+import qualified Paths_purescript as Paths
35+import qualified System.IO.UTF8 as U
36+
37+newtype SuperMap = SuperMap { unSuperMap :: Either P.ProperName (P.ProperName, P.ProperName) }
38+ deriving Eq
39+
40+instance Show SuperMap where
41+ show (SuperMap (Left sub)) = show sub
42+ show (SuperMap (Right (super, sub))) = show super ++ " -> " ++ show sub
43+
44+instance Ord SuperMap where
45+ compare (SuperMap s) (SuperMap s') = getCls s `compare` getCls s'
46+ where
47+ getCls = either id snd
48+
49+runModuleName :: P.ModuleName -> String
50+runModuleName (P.ModuleName pns) = intercalate "_" (P.runProperName `map` pns)
51+
52+readInput :: FilePath -> IO (Either ParseError [P.Module])
53+readInput p = do
54+ text <- U.readFile p
55+ return $ P.runIndentParser p P.parseModules text
56+
57+compile :: FilePath -> Maybe FilePath -> IO ()
58+compile input mOutput = do
59+ modules <- readInput input
60+ case modules of
61+ Left err -> U.hPutStr stderr (show err) >> exitFailure
62+ Right ms -> do
63+ for_ ms $ \(P.Module moduleName decls _) ->
64+ let name = runModuleName moduleName
65+ tcs = filter P.isTypeClassDeclaration decls
66+ supers = sort . nub . filter (not . null) $ fmap superClasses tcs
67+ prologue = "digraph " ++ name ++ " {\n"
68+ body = intercalate "\n" (concatMap (fmap (\s -> " " ++ show s ++ ";")) supers)
69+ epilogue = "\n}"
70+ hier = prologue ++ body ++ epilogue
71+ in unless (null supers) $ case mOutput of
72+ Just output -> do
73+ createDirectoryIfMissing True output
74+ U.writeFile (output </> name) hier
75+ Nothing -> U.putStrLn hier
76+ exitSuccess
77+
78+superClasses :: P.Declaration -> [SuperMap]
79+superClasses (P.TypeClassDeclaration sub _ supers@(_:_) _) =
80+ fmap (\(P.Qualified _ super, _) -> SuperMap (Right (super, sub))) supers
81+superClasses (P.TypeClassDeclaration sub _ _ _) = [SuperMap (Left sub)]
82+superClasses (P.PositionedDeclaration _ decl) = superClasses decl
83+superClasses _ = []
84+
85+outputFile :: Term (Maybe FilePath)
86+outputFile = value $ opt Nothing $ (optInfo [ "o", "output" ])
87+ { optDoc = "The output directory" }
88+
89+inputFile :: Term FilePath
90+inputFile = value $ pos 0 "main.purs" $ posInfo
91+ { posDoc = "The input file to generate a hierarchy from" }
92+
93+term :: Term (IO ())
94+term = compile <$> inputFile <*> outputFile
95+
96+termInfo :: TermInfo
97+termInfo = defTI
98+ { termName = "hierarchy"
99+ , version = showVersion Paths.version
100+ , termDoc = "Creates a GraphViz directed graph of PureScript TypeClasses"
101+ }
102+
103+main :: IO ()
104+main = run (term, termInfo)
package.yamldeleted−86
@@ -1,86 +0,0 @@
1−name: psgo
2−version: 0.1.0.0
3−github: "andyarvanitis/purescript-native"
4−license: BSD3
5−author: "Andy Arvanitis"
6−maintainer: "example@example.com"
7−copyright: "2018 Andy Arvanitis"
8−
9−extra-source-files:
10−- README.md
11−- ChangeLog.md
12−- stack.yaml
13−- support/*
14−
15−# Metadata used when publishing your package
16−# synopsis: Short description of your package
17−# category: Web
18−
19−# To avoid duplicated efforts in documentation and dealing with the
20−# complications of embedding Haddock markup inside cabal files, it is
21−# common to point users to the README.md file.
22−description: Please see the README on Github at <https://github.com/andyarvanitis/purescript-native#readme>
23−
24−dependencies:
25−- base >= 4.7 && < 5
26−- bytestring >= 0.10.8.2 && < 0.11
27−- purescript
28−- base-compat >=0.6.0
29−- protolude >=0.1.6
30−- text
31−- containers
32−- filepath
33−- monad-parallel >= 0.7.2.2 && <0.8
34−- pattern-arrows >=0.0.2 && <0.1
35−- safe >=0.3.9 && <0.4
36−- transformers >=0.3.0 && <0.6
37−- mtl >=2.1.0 && <2.3.0
38−- aeson >=1.0 && <1.5
39−- directory
40−- process
41−- file-embed
42−- filemanip
43−- gitrev
44−
45−library:
46− source-dirs: src
47− default-extensions:
48− - ConstraintKinds
49− - DataKinds
50− - DeriveFunctor
51− - EmptyDataDecls
52− - FlexibleContexts
53− - KindSignatures
54− - LambdaCase
55− - MultiParamTypeClasses
56− - NoImplicitPrelude
57− - PatternGuards
58− - PatternSynonyms
59− - RankNTypes
60− - RecordWildCards
61− - OverloadedStrings
62− - ScopedTypeVariables
63− - TupleSections
64− - ViewPatterns
65−
66−executables:
67− psgo:
68− main: Main.hs
69− source-dirs: app
70− ghc-options:
71− - -threaded
72− - -rtsopts
73− - -with-rtsopts=-N
74− dependencies:
75− - psgo
76−
77−tests:
78− psgo-test:
79− main: Spec.hs
80− source-dirs: test
81− ghc-options:
82− - -threaded
83− - -rtsopts
84− - -with-rtsopts=-N
85− dependencies:
86− - psgo
prelude/README.mdnew file+379
@@ -0,0 +1,379 @@
1+# Module Documentation
2+
3+## Module Prelude
4+
5+### Types
6+
7+ data Ordering where
8+ LT :: Ordering
9+ GT :: Ordering
10+ EQ :: Ordering
11+
12+ newtype Unit where
13+ Unit :: { } -> Unit
14+
15+
16+### Type Classes
17+
18+![Prelude](images/Prelude.png)
19+
20+ class (Apply f) <= Applicative f where
21+ pure :: forall a. a -> f a
22+
23+ class (Functor f) <= Apply f where
24+ (<*>) :: forall a b. f (a -> b) -> f a -> f b
25+
26+ class (Apply m) <= Bind m where
27+ (>>=) :: forall a b. m a -> (a -> m b) -> m b
28+
29+ class Bits b where
30+ (&) :: b -> b -> b
31+ (|) :: b -> b -> b
32+ (^) :: b -> b -> b
33+ shl :: b -> Number -> b
34+ shr :: b -> Number -> b
35+ zshr :: b -> Number -> b
36+ complement :: b -> b
37+
38+ class BoolLike b where
39+ (&&) :: b -> b -> b
40+ (||) :: b -> b -> b
41+ not :: b -> b
42+
43+ class (Semigroupoid a) <= Category a where
44+ id :: forall t. a t t
45+
46+ class Eq a where
47+ (==) :: a -> a -> Boolean
48+ (/=) :: a -> a -> Boolean
49+
50+ class Functor f where
51+ (<$>) :: forall a b. (a -> b) -> f a -> f b
52+
53+ class (Applicative m, Bind m) <= Monad m where
54+
55+ class Num a where
56+ (+) :: a -> a -> a
57+ (-) :: a -> a -> a
58+ (*) :: a -> a -> a
59+ (/) :: a -> a -> a
60+ (%) :: a -> a -> a
61+ negate :: a -> a
62+
63+ class (Eq a) <= Ord a where
64+ compare :: a -> a -> Ordering
65+
66+ class Semigroup a where
67+ (<>) :: a -> a -> a
68+
69+ class Semigroupoid a where
70+ (<<<) :: forall b c d. a c d -> a b c -> a b d
71+
72+ class Show a where
73+ show :: a -> String
74+
75+
76+### Type Class Instances
77+
78+ instance applicativeArr :: Applicative (Prim.Function r)
79+
80+ instance applyArr :: Apply (Prim.Function r)
81+
82+ instance bindArr :: Bind (Prim.Function r)
83+
84+ instance bitsNumber :: Bits Number
85+
86+ instance boolLikeBoolean :: BoolLike Boolean
87+
88+ instance categoryArr :: Category Prim.Function
89+
90+ instance eqArray :: (Eq a) => Eq [a]
91+
92+ instance eqBoolean :: Eq Boolean
93+
94+ instance eqNumber :: Eq Number
95+
96+ instance eqOrdering :: Eq Ordering
97+
98+ instance eqString :: Eq String
99+
100+ instance eqUnit :: Eq Unit
101+
102+ instance functorArr :: Functor (Prim.Function r)
103+
104+ instance monadArr :: Monad (Prim.Function r)
105+
106+ instance numNumber :: Num Number
107+
108+ instance ordArray :: (Ord a) => Ord [a]
109+
110+ instance ordBoolean :: Ord Boolean
111+
112+ instance ordNumber :: Ord Number
113+
114+ instance ordString :: Ord String
115+
116+ instance ordUnit :: Ord Unit
117+
118+ instance semigroupArr :: (Semigroup s') => Semigroup (s -> s')
119+
120+ instance semigroupString :: Semigroup String
121+
122+ instance semigroupUnit :: Semigroup Unit
123+
124+ instance semigroupoidArr :: Semigroupoid Prim.Function
125+
126+ instance showArray :: (Show a) => Show [a]
127+
128+ instance showBoolean :: Show Boolean
129+
130+ instance showNumber :: Show Number
131+
132+ instance showOrdering :: Show Ordering
133+
134+ instance showString :: Show String
135+
136+ instance showUnit :: Show Unit
137+
138+
139+### Values
140+
141+ (#) :: forall a b. a -> (a -> b) -> b
142+
143+ ($) :: forall a b. (a -> b) -> a -> b
144+
145+ (++) :: forall s. (Semigroup s) => s -> s -> s
146+
147+ (:) :: forall a. a -> [a] -> [a]
148+
149+ (<) :: forall a. (Ord a) => a -> a -> Boolean
150+
151+ (<=) :: forall a. (Ord a) => a -> a -> Boolean
152+
153+ (>) :: forall a. (Ord a) => a -> a -> Boolean
154+
155+ (>=) :: forall a. (Ord a) => a -> a -> Boolean
156+
157+ (>>>) :: forall a b c d. (Semigroupoid a) => a b c -> a c d -> a b d
158+
159+ ap :: forall m a b. (Monad m) => m (a -> b) -> m a -> m b
160+
161+ asTypeOf :: forall a. a -> a -> a
162+
163+ cons :: forall a. a -> [a] -> [a]
164+
165+ const :: forall a b. a -> b -> a
166+
167+ flip :: forall a b c. (a -> b -> c) -> b -> a -> c
168+
169+ liftA1 :: forall f a b. (Applicative f) => (a -> b) -> f a -> f b
170+
171+ liftM1 :: forall m a b. (Monad m) => (a -> b) -> m a -> m b
172+
173+ refEq :: forall a. a -> a -> Boolean
174+
175+ refIneq :: forall a. a -> a -> Boolean
176+
177+ return :: forall m a. (Monad m) => a -> m a
178+
179+ unit :: Unit
180+
181+ void :: forall f a. (Functor f) => f a -> f Unit
182+
183+
184+## Module Data.Function
185+
186+### Types
187+
188+ data Fn0 :: * -> *
189+
190+ data Fn1 :: * -> * -> *
191+
192+ data Fn10 :: * -> * -> * -> * -> * -> * -> * -> * -> * -> * -> * -> *
193+
194+ data Fn2 :: * -> * -> * -> *
195+
196+ data Fn3 :: * -> * -> * -> * -> *
197+
198+ data Fn4 :: * -> * -> * -> * -> * -> *
199+
200+ data Fn5 :: * -> * -> * -> * -> * -> * -> *
201+
202+ data Fn6 :: * -> * -> * -> * -> * -> * -> * -> *
203+
204+ data Fn7 :: * -> * -> * -> * -> * -> * -> * -> * -> *
205+
206+ data Fn8 :: * -> * -> * -> * -> * -> * -> * -> * -> * -> *
207+
208+ data Fn9 :: * -> * -> * -> * -> * -> * -> * -> * -> * -> * -> *
209+
210+
211+### Values
212+
213+ mkFn0 :: forall a. (Unit -> a) -> Fn0 a
214+
215+ mkFn1 :: forall a b. (a -> b) -> Fn1 a b
216+
217+ mkFn10 :: forall a b c d e f g h i j k. (a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k) -> Fn10 a b c d e f g h i j k
218+
219+ mkFn2 :: forall a b c. (a -> b -> c) -> Fn2 a b c
220+
221+ mkFn3 :: forall a b c d. (a -> b -> c -> d) -> Fn3 a b c d
222+
223+ mkFn4 :: forall a b c d e. (a -> b -> c -> d -> e) -> Fn4 a b c d e
224+
225+ mkFn5 :: forall a b c d e f. (a -> b -> c -> d -> e -> f) -> Fn5 a b c d e f
226+
227+ mkFn6 :: forall a b c d e f g. (a -> b -> c -> d -> e -> f -> g) -> Fn6 a b c d e f g
228+
229+ mkFn7 :: forall a b c d e f g h. (a -> b -> c -> d -> e -> f -> g -> h) -> Fn7 a b c d e f g h
230+
231+ mkFn8 :: forall a b c d e f g h i. (a -> b -> c -> d -> e -> f -> g -> h -> i) -> Fn8 a b c d e f g h i
232+
233+ mkFn9 :: forall a b c d e f g h i j. (a -> b -> c -> d -> e -> f -> g -> h -> i -> j) -> Fn9 a b c d e f g h i j
234+
235+ on :: forall a b c. (b -> b -> c) -> (a -> b) -> a -> a -> c
236+
237+ runFn0 :: forall a. Fn0 a -> a
238+
239+ runFn1 :: forall a b. Fn1 a b -> a -> b
240+
241+ runFn10 :: forall a b c d e f g h i j k. Fn10 a b c d e f g h i j k -> a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k
242+
243+ runFn2 :: forall a b c. Fn2 a b c -> a -> b -> c
244+
245+ runFn3 :: forall a b c d. Fn3 a b c d -> a -> b -> c -> d
246+
247+ runFn4 :: forall a b c d e. Fn4 a b c d e -> a -> b -> c -> d -> e
248+
249+ runFn5 :: forall a b c d e f. Fn5 a b c d e f -> a -> b -> c -> d -> e -> f
250+
251+ runFn6 :: forall a b c d e f g. Fn6 a b c d e f g -> a -> b -> c -> d -> e -> f -> g
252+
253+ runFn7 :: forall a b c d e f g h. Fn7 a b c d e f g h -> a -> b -> c -> d -> e -> f -> g -> h
254+
255+ runFn8 :: forall a b c d e f g h i. Fn8 a b c d e f g h i -> a -> b -> c -> d -> e -> f -> g -> h -> i
256+
257+ runFn9 :: forall a b c d e f g h i j. Fn9 a b c d e f g h i j -> a -> b -> c -> d -> e -> f -> g -> h -> i -> j
258+
259+
260+## Module Data.Eq
261+
262+### Types
263+
264+ newtype Ref a where
265+ Ref :: a -> Ref
266+
267+
268+### Type Class Instances
269+
270+ instance eqRef :: Eq (Ref a)
271+
272+ instance functorRef :: Functor Ref
273+
274+
275+### Values
276+
277+ liftRef :: forall a b. (a -> a -> b) -> Ref a -> Ref a -> b
278+
279+
280+## Module Prelude.Unsafe
281+
282+### Values
283+
284+ unsafeIndex :: forall a. [a] -> Number -> a
285+
286+
287+## Module Control.Monad.Eff
288+
289+### Types
290+
291+ data Eff :: # ! -> * -> *
292+
293+ type Pure a = forall e. Eff e a
294+
295+
296+### Type Class Instances
297+
298+ instance applicativeEff :: Applicative (Eff e)
299+
300+ instance applyEff :: Apply (Eff e)
301+
302+ instance bindEff :: Bind (Eff e)
303+
304+ instance functorEff :: Functor (Eff e)
305+
306+ instance monadEff :: Monad (Eff e)
307+
308+
309+### Values
310+
311+ bindE :: forall e a b. Eff e a -> (a -> Eff e b) -> Eff e b
312+
313+ forE :: forall e. Number -> Number -> (Number -> Eff e Unit) -> Eff e Unit
314+
315+ foreachE :: forall e a. [a] -> (a -> Eff e Unit) -> Eff e Unit
316+
317+ returnE :: forall e a. a -> Eff e a
318+
319+ runPure :: forall a. Pure a -> a
320+
321+ untilE :: forall e. Eff e Boolean -> Eff e Unit
322+
323+ whileE :: forall e a. Eff e Boolean -> Eff e a -> Eff e Unit
324+
325+
326+## Module Control.Monad.Eff.Unsafe
327+
328+### Values
329+
330+ unsafeInterleaveEff :: forall eff1 eff2 a. Eff eff1 a -> Eff eff2 a
331+
332+
333+## Module Debug.Trace
334+
335+### Types
336+
337+ data Trace :: !
338+
339+
340+### Values
341+
342+ print :: forall a r. (Show a) => a -> Eff (trace :: Trace | r) Unit
343+
344+ trace :: forall r. String -> Eff (trace :: Trace | r) Unit
345+
346+
347+## Module Control.Monad.ST
348+
349+### Types
350+
351+ data ST :: * -> !
352+
353+ data STArray :: * -> * -> *
354+
355+ data STRef :: * -> * -> *
356+
357+
358+### Values
359+
360+ modifySTRef :: forall a h r. STRef h a -> (a -> a) -> Eff (st :: ST h | r) a
361+
362+ newSTArray :: forall a h r. Number -> a -> Eff (st :: ST h | r) (STArray h a)
363+
364+ newSTRef :: forall a h r. a -> Eff (st :: ST h | r) (STRef h a)
365+
366+ peekSTArray :: forall a h r. STArray h a -> Number -> Eff (st :: ST h | r) a
367+
368+ pokeSTArray :: forall a h r. STArray h a -> Number -> a -> Eff (st :: ST h | r) a
369+
370+ readSTRef :: forall a h r. STRef h a -> Eff (st :: ST h | r) a
371+
372+ runST :: forall a r. (forall h. Eff (st :: ST h | r) a) -> Eff r a
373+
374+ runSTArray :: forall a r. (forall h. Eff (st :: ST h | r) (STArray h a)) -> Eff r [a]
375+
376+ writeSTRef :: forall a h r. STRef h a -> a -> Eff (st :: ST h | r) a
377+
378+
379+
prelude/images/Prelude.pngnew file

Binary file not shown.

prelude/prelude.pursnew file+952
@@ -0,0 +1,952 @@
1+module Prelude
2+ ( otherwise
3+ , flip
4+ , const
5+ , asTypeOf
6+ , Semigroupoid, (<<<), (>>>)
7+ , Category, id
8+ , ($), (#)
9+ , (:), cons
10+ , Show, show
11+ , Functor, (<$>), (<#>), void
12+ , Apply, (<*>)
13+ , Applicative, pure, liftA1
14+ , Bind, (>>=)
15+ , Monad, return, liftM1, ap
16+ , Num, (+), (-), (*), (/), (%)
17+ , negate
18+ , Eq, (==), (/=), refEq, refIneq
19+ , Ord, Ordering(..), compare, (<), (>), (<=), (>=)
20+ , Bits, (&), (|), (^), shl, shr, zshr, complement
21+ , BoolLike, (&&), (||)
22+ , not
23+ , Semigroup, (<>), (++)
24+ , Unit(..), unit
25+ ) where
26+
27+ otherwise :: Boolean
28+ otherwise = true
29+
30+ flip :: forall a b c. (a -> b -> c) -> b -> a -> c
31+ flip f b a = f a b
32+
33+ const :: forall a b. a -> b -> a
34+ const a _ = a
35+
36+ asTypeOf :: forall a. a -> a -> a
37+ asTypeOf x _ = x
38+
39+ infixr 9 >>>
40+ infixr 9 <<<
41+
42+ class Semigroupoid a where
43+ (<<<) :: forall b c d. a c d -> a b c -> a b d
44+
45+ instance semigroupoidArr :: Semigroupoid (->) where
46+ (<<<) f g x = f (g x)
47+
48+ (>>>) :: forall a b c d. (Semigroupoid a) => a b c -> a c d -> a b d
49+ (>>>) f g = g <<< f
50+
51+ class (Semigroupoid a) <= Category a where
52+ id :: forall t. a t t
53+
54+ instance categoryArr :: Category (->) where
55+ id x = x
56+
57+ infixr 0 $
58+ infixl 0 #
59+
60+ ($) :: forall a b. (a -> b) -> a -> b
61+ ($) f x = f x
62+
63+ (#) :: forall a b. a -> (a -> b) -> b
64+ (#) x f = f x
65+
66+ infixr 6 :
67+
68+ (:) :: forall a. a -> [a] -> [a]
69+ (:) = cons
70+
71+ foreign import cons
72+ "function cons(e) {\
73+ \ return function(l) {\
74+ \ return [e].concat(l);\
75+ \ };\
76+ \}" :: forall a. a -> [a] -> [a]
77+
78+ class Show a where
79+ show :: a -> String
80+
81+ foreign import showStringImpl
82+ "function showStringImpl(s) {\
83+ \ return JSON.stringify(s);\
84+ \}" :: String -> String
85+
86+ instance showUnit :: Show Unit where
87+ show (Unit {}) = "Unit {}"
88+
89+ instance showString :: Show String where
90+ show = showStringImpl
91+
92+ instance showBoolean :: Show Boolean where
93+ show true = "true"
94+ show false = "false"
95+
96+ foreign import showNumberImpl "function showNumberImpl(n) {\
97+ \ return n.toString();\
98+ \}" :: Number -> String
99+
100+ instance showNumber :: Show Number where
101+ show = showNumberImpl
102+
103+ foreign import showArrayImpl
104+ "function showArrayImpl(f) {\
105+ \ return function(xs) {\
106+ \ var ss = [];\
107+ \ for (var i = 0, l = xs.length; i < l; i++) {\
108+ \ ss[i] = f(xs[i]);\
109+ \ }\
110+ \ return '[' + ss.join(',') + ']';\
111+ \ };\
112+ \}" :: forall a. (a -> String) -> [a] -> String
113+
114+ instance showArray :: (Show a) => Show [a] where
115+ show = showArrayImpl show
116+
117+ infixl 4 <$>
118+ infixl 1 <#>
119+
120+ class Functor f where
121+ (<$>) :: forall a b. (a -> b) -> f a -> f b
122+
123+ (<#>) :: forall f a b. (Functor f) => f a -> (a -> b) -> f b
124+ (<#>) fa f = f <$> fa
125+
126+ void :: forall f a. (Functor f) => f a -> f Unit
127+ void fa = const unit <$> fa
128+
129+ infixl 4 <*>
130+
131+ class (Functor f) <= Apply f where
132+ (<*>) :: forall a b. f (a -> b) -> f a -> f b
133+
134+ class (Apply f) <= Applicative f where
135+ pure :: forall a. a -> f a
136+
137+ liftA1 :: forall f a b. (Applicative f) => (a -> b) -> f a -> f b
138+ liftA1 f a = pure f <*> a
139+
140+ infixl 1 >>=
141+
142+ class (Apply m) <= Bind m where
143+ (>>=) :: forall a b. m a -> (a -> m b) -> m b
144+
145+ class (Applicative m, Bind m) <= Monad m
146+
147+ return :: forall m a. (Monad m) => a -> m a
148+ return = pure
149+
150+ liftM1 :: forall m a b. (Monad m) => (a -> b) -> m a -> m b
151+ liftM1 f a = do
152+ a' <- a
153+ return (f a')
154+
155+ ap :: forall m a b. (Monad m) => m (a -> b) -> m a -> m b
156+ ap f a = do
157+ f' <- f
158+ a' <- a
159+ return (f' a')
160+
161+ instance functorArr :: Functor ((->) r) where
162+ (<$>) = (<<<)
163+
164+ instance applyArr :: Apply ((->) r) where
165+ (<*>) f g x = f x (g x)
166+
167+ instance applicativeArr :: Applicative ((->) r) where
168+ pure = const
169+
170+ instance bindArr :: Bind ((->) r) where
171+ (>>=) m f x = f (m x) x
172+
173+ instance monadArr :: Monad ((->) r)
174+
175+ infixl 7 *
176+ infixl 7 /
177+ infixl 7 %
178+
179+ infixl 6 -
180+ infixl 6 +
181+
182+ class Num a where
183+ (+) :: a -> a -> a
184+ (-) :: a -> a -> a
185+ (*) :: a -> a -> a
186+ (/) :: a -> a -> a
187+ (%) :: a -> a -> a
188+ negate :: a -> a
189+
190+ foreign import numAdd "function numAdd(n1) {\
191+ \ return function(n2) {\
192+ \ return n1 + n2;\
193+ \ };\
194+ \}" :: Number -> Number -> Number
195+
196+ foreign import numSub "function numSub(n1) {\
197+ \ return function(n2) {\
198+ \ return n1 - n2;\
199+ \ };\
200+ \}" :: Number -> Number -> Number
201+
202+ foreign import numMul "function numMul(n1) {\
203+ \ return function(n2) {\
204+ \ return n1 * n2;\
205+ \ };\
206+ \}" :: Number -> Number -> Number
207+
208+ foreign import numDiv "function numDiv(n1) {\
209+ \ return function(n2) {\
210+ \ return n1 / n2;\
211+ \ };\
212+ \}" :: Number -> Number -> Number
213+
214+ foreign import numMod "function numMod(n1) {\
215+ \ return function(n2) {\
216+ \ return n1 % n2;\
217+ \ };\
218+ \}" :: Number -> Number -> Number
219+
220+ foreign import numNegate "function numNegate(n) {\
221+ \ return -n;\
222+ \}" :: Number -> Number
223+
224+ instance numNumber :: Num Number where
225+ (+) = numAdd
226+ (-) = numSub
227+ (*) = numMul
228+ (/) = numDiv
229+ (%) = numMod
230+ negate = numNegate
231+
232+ newtype Unit = Unit {}
233+
234+ unit :: Unit
235+ unit = Unit {}
236+
237+ infix 4 ==
238+ infix 4 /=
239+
240+ class Eq a where
241+ (==) :: a -> a -> Boolean
242+ (/=) :: a -> a -> Boolean
243+
244+ foreign import refEq
245+ "function refEq(r1) {\
246+ \ return function(r2) {\
247+ \ return r1 === r2;\
248+ \ };\
249+ \}" :: forall a. a -> a -> Boolean
250+
251+ foreign import refIneq
252+ "function refIneq(r1) {\
253+ \ return function(r2) {\
254+ \ return r1 !== r2;\
255+ \ };\
256+ \}" :: forall a. a -> a -> Boolean
257+
258+ instance eqUnit :: Eq Unit where
259+ (==) (Unit {}) (Unit {}) = true
260+ (/=) (Unit {}) (Unit {}) = false
261+
262+ instance eqString :: Eq String where
263+ (==) = refEq
264+ (/=) = refIneq
265+
266+ instance eqNumber :: Eq Number where
267+ (==) = refEq
268+ (/=) = refIneq
269+
270+ instance eqBoolean :: Eq Boolean where
271+ (==) = refEq
272+ (/=) = refIneq
273+
274+ foreign import eqArrayImpl
275+ "function eqArrayImpl(f) {\
276+ \ return function(xs) {\
277+ \ return function(ys) {\
278+ \ if (xs.length !== ys.length) return false;\
279+ \ for (var i = 0; i < xs.length; i++) {\
280+ \ if (!f(xs[i])(ys[i])) return false;\
281+ \ }\
282+ \ return true;\
283+ \ };\
284+ \ };\
285+ \}" :: forall a. (a -> a -> Boolean) -> [a] -> [a] -> Boolean
286+
287+ instance eqArray :: (Eq a) => Eq [a] where
288+ (==) xs ys = eqArrayImpl (==) xs ys
289+ (/=) xs ys = not (xs == ys)
290+
291+ data Ordering = LT | GT | EQ
292+
293+ instance eqOrdering :: Eq Ordering where
294+ (==) LT LT = true
295+ (==) GT GT = true
296+ (==) EQ EQ = true
297+ (==) _ _ = false
298+ (/=) x y = not (x == y)
299+
300+ instance showOrdering :: Show Ordering where
301+ show LT = "LT"
302+ show GT = "GT"
303+ show EQ = "EQ"
304+
305+ class (Eq a) <= Ord a where
306+ compare :: a -> a -> Ordering
307+
308+ infixl 4 <
309+
310+ (<) :: forall a. (Ord a) => a -> a -> Boolean
311+ (<) a1 a2 = case a1 `compare` a2 of
312+ LT -> true
313+ _ -> false
314+
315+ infixl 4 >
316+
317+ (>) :: forall a. (Ord a) => a -> a -> Boolean
318+ (>) a1 a2 = case a1 `compare` a2 of
319+ GT -> true
320+ _ -> false
321+
322+ infixl 4 <=
323+
324+ (<=) :: forall a. (Ord a) => a -> a -> Boolean
325+ (<=) a1 a2 = case a1 `compare` a2 of
326+ GT -> false
327+ _ -> true
328+
329+ infixl 4 >=
330+
331+ (>=) :: forall a. (Ord a) => a -> a -> Boolean
332+ (>=) a1 a2 = case a1 `compare` a2 of
333+ LT -> false
334+ _ -> true
335+
336+ foreign import unsafeCompareImpl
337+ "function unsafeCompareImpl(lt) {\
338+ \ return function(eq) {\
339+ \ return function(gt) {\
340+ \ return function(x) {\
341+ \ return function(y) {\
342+ \ return x < y ? lt : x > y ? gt : eq;\
343+ \ };\
344+ \ };\
345+ \ };\
346+ \ };\
347+ \}" :: forall a. Ordering -> Ordering -> Ordering -> a -> a -> Ordering
348+
349+ unsafeCompare :: forall a. a -> a -> Ordering
350+ unsafeCompare = unsafeCompareImpl LT EQ GT
351+
352+ instance ordUnit :: Ord Unit where
353+ compare (Unit {}) (Unit {}) = EQ
354+
355+ instance ordBoolean :: Ord Boolean where
356+ compare false false = EQ
357+ compare false true = LT
358+ compare true true = EQ
359+ compare true false = GT
360+
361+ instance ordNumber :: Ord Number where
362+ compare = unsafeCompare
363+
364+ instance ordString :: Ord String where
365+ compare = unsafeCompare
366+
367+ instance ordArray :: (Ord a) => Ord [a] where
368+ compare [] [] = EQ
369+ compare [] _ = LT
370+ compare _ [] = GT
371+ compare (x:xs) (y:ys) = case compare x y of
372+ EQ -> compare xs ys
373+ other -> other
374+
375+ infixl 10 &
376+ infixl 10 |
377+ infixl 10 ^
378+
379+ class Bits b where
380+ (&) :: b -> b -> b
381+ (|) :: b -> b -> b
382+ (^) :: b -> b -> b
383+ shl :: b -> Number -> b
384+ shr :: b -> Number -> b
385+ zshr :: b -> Number -> b
386+ complement :: b -> b
387+
388+ foreign import numShl "function numShl(n1) {\
389+ \ return function(n2) {\
390+ \ return n1 << n2;\
391+ \ };\
392+ \}" :: Number -> Number -> Number
393+
394+ foreign import numShr "function numShr(n1) {\
395+ \ return function(n2) {\
396+ \ return n1 >> n2;\
397+ \ };\
398+ \}" :: Number -> Number -> Number
399+
400+ foreign import numZshr "function numZshr(n1) {\
401+ \ return function(n2) {\
402+ \ return n1 >>> n2;\
403+ \ };\
404+ \}" :: Number -> Number -> Number
405+
406+ foreign import numAnd "function numAnd(n1) {\
407+ \ return function(n2) {\
408+ \ return n1 & n2;\
409+ \ };\
410+ \}" :: Number -> Number -> Number
411+
412+ foreign import numOr "function numOr(n1) {\
413+ \ return function(n2) {\
414+ \ return n1 | n2;\
415+ \ };\
416+ \}" :: Number -> Number -> Number
417+
418+ foreign import numXor "function numXor(n1) {\
419+ \ return function(n2) {\
420+ \ return n1 ^ n2;\
421+ \ };\
422+ \}" :: Number -> Number -> Number
423+
424+ foreign import numComplement "function numComplement(n) {\
425+ \ return ~n;\
426+ \}" :: Number -> Number
427+
428+ instance bitsNumber :: Bits Number where
429+ (&) = numAnd
430+ (|) = numOr
431+ (^) = numXor
432+ shl = numShl
433+ shr = numShr
434+ zshr = numZshr
435+ complement = numComplement
436+
437+ infixr 2 ||
438+ infixr 3 &&
439+
440+ class BoolLike b where
441+ (&&) :: b -> b -> b
442+ (||) :: b -> b -> b
443+ not :: b -> b
444+
445+ foreign import boolAnd "function boolAnd(b1) {\
446+ \ return function(b2) {\
447+ \ return b1 && b2;\
448+ \ };\
449+ \}" :: Boolean -> Boolean -> Boolean
450+
451+ foreign import boolOr "function boolOr(b1) {\
452+ \ return function(b2) {\
453+ \ return b1 || b2;\
454+ \ };\
455+ \}" :: Boolean -> Boolean -> Boolean
456+
457+ foreign import boolNot "function boolNot(b) {\
458+ \ return !b;\
459+ \}" :: Boolean -> Boolean
460+
461+ instance boolLikeBoolean :: BoolLike Boolean where
462+ (&&) = boolAnd
463+ (||) = boolOr
464+ not = boolNot
465+
466+ infixr 5 <>
467+
468+ class Semigroup a where
469+ (<>) :: a -> a -> a
470+
471+ foreign import concatString
472+ "function concatString(s1) {\
473+ \ return function(s2) {\
474+ \ return s1 + s2;\
475+ \ };\
476+ \}" :: String -> String -> String
477+
478+ instance semigroupUnit :: Semigroup Unit where
479+ (<>) (Unit {}) (Unit {}) = Unit {}
480+
481+ instance semigroupString :: Semigroup String where
482+ (<>) = concatString
483+
484+ instance semigroupArr :: (Semigroup s') => Semigroup (s -> s') where
485+ (<>) f g = \x -> f x <> g x
486+
487+ infixr 5 ++
488+
489+ (++) :: forall s. (Semigroup s) => s -> s -> s
490+ (++) = (<>)
491+
492+module Data.Function where
493+
494+ on :: forall a b c. (b -> b -> c) -> (a -> b) -> a -> a -> c
495+ on f g x y = g x `f` g y
496+
497+ foreign import data Fn0 :: * -> *
498+ foreign import data Fn1 :: * -> * -> *
499+ foreign import data Fn2 :: * -> * -> * -> *
500+ foreign import data Fn3 :: * -> * -> * -> * -> *
501+ foreign import data Fn4 :: * -> * -> * -> * -> * -> *
502+ foreign import data Fn5 :: * -> * -> * -> * -> * -> * -> *
503+ foreign import data Fn6 :: * -> * -> * -> * -> * -> * -> * -> *
504+ foreign import data Fn7 :: * -> * -> * -> * -> * -> * -> * -> * -> *
505+ foreign import data Fn8 :: * -> * -> * -> * -> * -> * -> * -> * -> * -> *
506+ foreign import data Fn9 :: * -> * -> * -> * -> * -> * -> * -> * -> * -> * -> *
507+ foreign import data Fn10 :: * -> * -> * -> * -> * -> * -> * -> * -> * -> * -> * -> *
508+
509+ foreign import mkFn0
510+ "function mkFn0(fn) {\
511+ \ return function() {\
512+ \ return fn({});\
513+ \ };\
514+ \}" :: forall a. (Unit -> a) -> Fn0 a
515+
516+ foreign import mkFn1
517+ "function mkFn1(fn) {\
518+ \ return function(a) {\
519+ \ return fn(a);\
520+ \ };\
521+ \}" :: forall a b. (a -> b) -> Fn1 a b
522+
523+ foreign import mkFn2
524+ "function mkFn2(fn) {\
525+ \ return function(a, b) {\
526+ \ return fn(a)(b);\
527+ \ };\
528+ \}" :: forall a b c. (a -> b -> c) -> Fn2 a b c
529+
530+ foreign import mkFn3
531+ "function mkFn3(fn) {\
532+ \ return function(a, b, c) {\
533+ \ return fn(a)(b)(c);\
534+ \ };\
535+ \}" :: forall a b c d. (a -> b -> c -> d) -> Fn3 a b c d
536+
537+ foreign import mkFn4
538+ "function mkFn4(fn) {\
539+ \ return function(a, b, c, d) {\
540+ \ return fn(a)(b)(c)(d);\
541+ \ };\
542+ \}" :: forall a b c d e. (a -> b -> c -> d -> e) -> Fn4 a b c d e
543+
544+ foreign import mkFn5
545+ "function mkFn5(fn) {\
546+ \ return function(a, b, c, d, e) {\
547+ \ return fn(a)(b)(c)(d)(e);\
548+ \ };\
549+ \}" :: forall a b c d e f. (a -> b -> c -> d -> e -> f) -> Fn5 a b c d e f
550+
551+ foreign import mkFn6
552+ "function mkFn6(fn) {\
553+ \ return function(a, b, c, d, e, f) {\
554+ \ return fn(a)(b)(c)(d)(e)(f);\
555+ \ };\
556+ \}" :: forall a b c d e f g. (a -> b -> c -> d -> e -> f -> g) -> Fn6 a b c d e f g
557+
558+ foreign import mkFn7
559+ "function mkFn7(fn) {\
560+ \ return function(a, b, c, d, e, f, g) {\
561+ \ return fn(a)(b)(c)(d)(e)(f)(g);\
562+ \ };\
563+ \}" :: forall a b c d e f g h. (a -> b -> c -> d -> e -> f -> g -> h) -> Fn7 a b c d e f g h
564+
565+ foreign import mkFn8
566+ "function mkFn8(fn) {\
567+ \ return function(a, b, c, d, e, f, g, h) {\
568+ \ return fn(a)(b)(c)(d)(e)(f)(g)(h);\
569+ \ };\
570+ \}" :: forall a b c d e f g h i. (a -> b -> c -> d -> e -> f -> g -> h -> i) -> Fn8 a b c d e f g h i
571+
572+ foreign import mkFn9
573+ "function mkFn9(fn) {\
574+ \ return function(a, b, c, d, e, f, g, h, i) {\
575+ \ return fn(a)(b)(c)(d)(e)(f)(g)(h)(i);\
576+ \ };\
577+ \}" :: forall a b c d e f g h i j. (a -> b -> c -> d -> e -> f -> g -> h -> i -> j) -> Fn9 a b c d e f g h i j
578+
579+ foreign import mkFn10
580+ "function mkFn10(fn) {\
581+ \ return function(a, b, c, d, e, f, g, h, i, j) {\
582+ \ return fn(a)(b)(c)(d)(e)(f)(g)(h)(i)(j);\
583+ \ };\
584+ \}" :: forall a b c d e f g h i j k. (a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k) -> Fn10 a b c d e f g h i j k
585+
586+ foreign import runFn0
587+ "function runFn0(fn) {\
588+ \ return fn();\
589+ \}" :: forall a. Fn0 a -> a
590+
591+ foreign import runFn1
592+ "function runFn1(fn) {\
593+ \ return function(a) {\
594+ \ return fn(a);\
595+ \ };\
596+ \}" :: forall a b. Fn1 a b -> a -> b
597+
598+ foreign import runFn2
599+ "function runFn2(fn) {\
600+ \ return function(a) {\
601+ \ return function(b) {\
602+ \ return fn(a, b);\
603+ \ };\
604+ \ };\
605+ \}" :: forall a b c. Fn2 a b c -> a -> b -> c
606+
607+ foreign import runFn3
608+ "function runFn3(fn) {\
609+ \ return function(a) {\
610+ \ return function(b) {\
611+ \ return function(c) {\
612+ \ return fn(a, b, c);\
613+ \ };\
614+ \ };\
615+ \ };\
616+ \}" :: forall a b c d. Fn3 a b c d -> a -> b -> c -> d
617+
618+ foreign import runFn4
619+ "function runFn4(fn) {\
620+ \ return function(a) {\
621+ \ return function(b) {\
622+ \ return function(c) {\
623+ \ return function(d) {\
624+ \ return fn(a, b, c, d);\
625+ \ };\
626+ \ };\
627+ \ };\
628+ \ };\
629+ \}" :: forall a b c d e. Fn4 a b c d e -> a -> b -> c -> d -> e
630+
631+ foreign import runFn5
632+ "function runFn5(fn) {\
633+ \ return function(a) {\
634+ \ return function(b) {\
635+ \ return function(c) {\
636+ \ return function(d) {\
637+ \ return function(e) {\
638+ \ return fn(a, b, c, d, e);\
639+ \ };\
640+ \ };\
641+ \ };\
642+ \ };\
643+ \ };\
644+ \}" :: forall a b c d e f. Fn5 a b c d e f -> a -> b -> c -> d -> e -> f
645+
646+ foreign import runFn6
647+ "function runFn6(fn) {\
648+ \ return function(a) {\
649+ \ return function(b) {\
650+ \ return function(c) {\
651+ \ return function(d) {\
652+ \ return function(e) {\
653+ \ return function(f) {\
654+ \ return fn(a, b, c, d, e, f);\
655+ \ };\
656+ \ };\
657+ \ };\
658+ \ };\
659+ \ };\
660+ \ };\
661+ \}" :: forall a b c d e f g. Fn6 a b c d e f g -> a -> b -> c -> d -> e -> f -> g
662+
663+ foreign import runFn7
664+ "function runFn7(fn) {\
665+ \ return function(a) {\
666+ \ return function(b) {\
667+ \ return function(c) {\
668+ \ return function(d) {\
669+ \ return function(e) {\
670+ \ return function(f) {\
671+ \ return function(g) {\
672+ \ return fn(a, b, c, d, e, f, g);\
673+ \ };\
674+ \ };\
675+ \ };\
676+ \ };\
677+ \ };\
678+ \ };\
679+ \ };\
680+ \}" :: forall a b c d e f g h. Fn7 a b c d e f g h -> a -> b -> c -> d -> e -> f -> g -> h
681+
682+ foreign import runFn8
683+ "function runFn8(fn) {\
684+ \ return function(a) {\
685+ \ return function(b) {\
686+ \ return function(c) {\
687+ \ return function(d) {\
688+ \ return function(e) {\
689+ \ return function(f) {\
690+ \ return function(g) {\
691+ \ return function(h) {\
692+ \ return fn(a, b, c, d, e, f, g, h);\
693+ \ };\
694+ \ };\
695+ \ };\
696+ \ };\
697+ \ };\
698+ \ };\
699+ \ };\
700+ \ };\
701+ \}" :: forall a b c d e f g h i. Fn8 a b c d e f g h i -> a -> b -> c -> d -> e -> f -> g -> h -> i
702+
703+ foreign import runFn9
704+ "function runFn9(fn) {\
705+ \ return function(a) {\
706+ \ return function(b) {\
707+ \ return function(c) {\
708+ \ return function(d) {\
709+ \ return function(e) {\
710+ \ return function(f) {\
711+ \ return function(g) {\
712+ \ return function(h) {\
713+ \ return function(i) {\
714+ \ return fn(a, b, c, d, e, f, g, h, i);\
715+ \ };\
716+ \ };\
717+ \ };\
718+ \ };\
719+ \ };\
720+ \ };\
721+ \ };\
722+ \ };\
723+ \ };\
724+ \}" :: forall a b c d e f g h i j. Fn9 a b c d e f g h i j -> a -> b -> c -> d -> e -> f -> g -> h -> i -> j
725+
726+ foreign import runFn10
727+ "function runFn10(fn) {\
728+ \ return function(a) {\
729+ \ return function(b) {\
730+ \ return function(c) {\
731+ \ return function(d) {\
732+ \ return function(e) {\
733+ \ return function(f) {\
734+ \ return function(g) {\
735+ \ return function(h) {\
736+ \ return function(i) {\
737+ \ return function(j) {\
738+ \ return fn(a, b, c, d, e, f, g, h, i, j);\
739+ \ };\
740+ \ };\
741+ \ };\
742+ \ };\
743+ \ };\
744+ \ };\
745+ \ };\
746+ \ };\
747+ \ };\
748+ \ };\
749+ \}" :: forall a b c d e f g h i j k. Fn10 a b c d e f g h i j k -> a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k
750+
751+module Data.Eq where
752+
753+ newtype Ref a = Ref a
754+
755+ liftRef :: forall a b. (a -> a -> b) -> Ref a -> Ref a -> b
756+ liftRef f (Ref x) (Ref y) = f x y
757+
758+ instance eqRef :: Eq (Ref a) where
759+ (==) = liftRef refEq
760+ (/=) = liftRef refIneq
761+
762+ instance functorRef :: Functor Ref where
763+ (<$>) f (Ref x) = Ref (f x)
764+
765+module Prelude.Unsafe where
766+
767+ foreign import unsafeIndex
768+ "function unsafeIndex(xs) {\
769+ \ return function(n) {\
770+ \ return xs[n];\
771+ \ };\
772+ \}" :: forall a. [a] -> Number -> a
773+
774+module Control.Monad.Eff where
775+
776+ foreign import data Eff :: # ! -> * -> *
777+
778+ foreign import returnE "function returnE(a) {\
779+ \ return function() {\
780+ \ return a;\
781+ \ };\
782+ \}" :: forall e a. a -> Eff e a
783+
784+ foreign import bindE "function bindE(a) {\
785+ \ return function(f) {\
786+ \ return function() {\
787+ \ return f(a())();\
788+ \ };\
789+ \ };\
790+ \}" :: forall e a b. Eff e a -> (a -> Eff e b) -> Eff e b
791+
792+ type Pure a = forall e. Eff e a
793+
794+ foreign import runPure "function runPure(f) {\
795+ \ return f();\
796+ \}" :: forall a. Pure a -> a
797+
798+ instance functorEff :: Functor (Eff e) where
799+ (<$>) = liftA1
800+
801+ instance applyEff :: Apply (Eff e) where
802+ (<*>) = ap
803+
804+ instance applicativeEff :: Applicative (Eff e) where
805+ pure = returnE
806+
807+ instance bindEff :: Bind (Eff e) where
808+ (>>=) = bindE
809+
810+ instance monadEff :: Monad (Eff e)
811+
812+ foreign import untilE "function untilE(f) {\
813+ \ return function() {\
814+ \ while (!f());\
815+ \ return {};\
816+ \ };\
817+ \}" :: forall e. Eff e Boolean -> Eff e Unit
818+
819+ foreign import whileE "function whileE(f) {\
820+ \ return function(a) {\
821+ \ return function() {\
822+ \ while (f()) {\
823+ \ a();\
824+ \ }\
825+ \ return {};\
826+ \ };\
827+ \ };\
828+ \}" :: forall e a. Eff e Boolean -> Eff e a -> Eff e Unit
829+
830+ foreign import forE "function forE(lo) {\
831+ \ return function(hi) {\
832+ \ return function(f) {\
833+ \ return function() {\
834+ \ for (var i = lo; i < hi; i++) {\
835+ \ f(i)();\
836+ \ }\
837+ \ };\
838+ \ };\
839+ \ };\
840+ \}" :: forall e. Number -> Number -> (Number -> Eff e Unit) -> Eff e Unit
841+
842+
843+ foreign import foreachE "function foreachE(as) {\
844+ \ return function(f) {\
845+ \ return function() {\
846+ \ for (var i = 0; i < as.length; i++) {\
847+ \ f(as[i])();\
848+ \ }\
849+ \ };\
850+ \ };\
851+ \}" :: forall e a. [a] -> (a -> Eff e Unit) -> Eff e Unit
852+
853+module Control.Monad.Eff.Unsafe where
854+
855+ import Control.Monad.Eff
856+
857+ foreign import unsafeInterleaveEff
858+ "function unsafeInterleaveEff(f) {\
859+ \ return f;\
860+ \}" :: forall eff1 eff2 a. Eff eff1 a -> Eff eff2 a
861+
862+module Debug.Trace where
863+
864+ import Control.Monad.Eff
865+
866+ foreign import data Trace :: !
867+
868+ foreign import trace "function trace(s) {\
869+ \ return function() {\
870+ \ console.log(s);\
871+ \ return {};\
872+ \ };\
873+ \}" :: forall r. String -> Eff (trace :: Trace | r) Unit
874+
875+ print :: forall a r. (Show a) => a -> Eff (trace :: Trace | r) Unit
876+ print o = trace (show o)
877+
878+module Control.Monad.ST where
879+
880+ import Control.Monad.Eff
881+
882+ foreign import data ST :: * -> !
883+
884+ foreign import data STRef :: * -> * -> *
885+
886+ foreign import data STArray :: * -> * -> *
887+
888+ foreign import newSTRef "function newSTRef(val) {\
889+ \ return function() {\
890+ \ return { value: val };\
891+ \ };\
892+ \}" :: forall a h r. a -> Eff (st :: ST h | r) (STRef h a)
893+
894+ foreign import readSTRef "function readSTRef(ref) {\
895+ \ return function() {\
896+ \ return ref.value;\
897+ \ };\
898+ \}" :: forall a h r. STRef h a -> Eff (st :: ST h | r) a
899+
900+ foreign import modifySTRef "function modifySTRef(ref) {\
901+ \ return function(f) {\
902+ \ return function() {\
903+ \ return ref.value = f(ref.value);\
904+ \ };\
905+ \ };\
906+ \}" :: forall a h r. STRef h a -> (a -> a) -> Eff (st :: ST h | r) a
907+
908+ foreign import writeSTRef "function writeSTRef(ref) {\
909+ \ return function(a) {\
910+ \ return function() {\
911+ \ return ref.value = a;\
912+ \ };\
913+ \ };\
914+ \}" :: forall a h r. STRef h a -> a -> Eff (st :: ST h | r) a
915+
916+ foreign import newSTArray "function newSTArray(len) {\
917+ \ return function(a) {\
918+ \ return function() {\
919+ \ var arr = [];\
920+ \ for (var i = 0; i < len; i++) {\
921+ \ arr[i] = a;\
922+ \ };\
923+ \ return arr;\
924+ \ };\
925+ \ };\
926+ \}" :: forall a h r. Number -> a -> Eff (st :: ST h | r) (STArray h a)
927+
928+ foreign import peekSTArray "function peekSTArray(arr) {\
929+ \ return function(i) {\
930+ \ return function() {\
931+ \ return arr[i];\
932+ \ };\
933+ \ };\
934+ \}" :: forall a h r. STArray h a -> Number -> Eff (st :: ST h | r) a
935+
936+ foreign import pokeSTArray "function pokeSTArray(arr) {\
937+ \ return function(i) {\
938+ \ return function(a) {\
939+ \ return function() {\
940+ \ return arr[i] = a;\
941+ \ };\
942+ \ };\
943+ \ };\
944+ \}" :: forall a h r. STArray h a -> Number -> a -> Eff (st :: ST h | r) a
945+
946+ foreign import runST "function runST(f) {\
947+ \ return f;\
948+ \}" :: forall a r. (forall h. Eff (st :: ST h | r) a) -> Eff r a
949+
950+ foreign import runSTArray "function runSTArray(f) {\
951+ \ return f;\
952+ \}" :: forall a r. (forall h. Eff (st :: ST h | r) (STArray h a)) -> Eff r [a]
prelude/updateDocs.shnew file+11
@@ -0,0 +1,11 @@
1+../dist/build/docgen/docgen --hierarchy-images prelude.purs > README.md
2+../dist/build/hierarchy/hierarchy prelude.purs -o prelude
3+
4+mkdir -p images
5+
6+for f in prelude/*; do
7+ BASE=$(basename "$f")
8+ dot -Tpng -o images/"$BASE".png "$f"
9+done
10+
11+rm -r prelude
psc-docs/Main.hsnew file+238
@@ -0,0 +1,238 @@
1+----------------------------------------------------------------------------
2+--
3+-- Module : Main
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+--
13+-----------------------------------------------------------------------------
14+
15+module Main where
16+
17+import Control.Applicative
18+import Control.Monad
19+import Control.Monad.Writer
20+import Control.Arrow (first)
21+import Data.Function (on)
22+import Data.List
23+import Data.Maybe (fromMaybe)
24+import Data.Version (showVersion)
25+import qualified Language.PureScript as P
26+import qualified Paths_purescript as Paths
27+import qualified System.IO.UTF8 as U
28+import System.Console.CmdTheLine
29+import System.Exit (exitSuccess, exitFailure)
30+import System.IO (stderr)
31+
32+docgen :: Bool -> [FilePath] -> IO ()
33+docgen showHierarchy input = do
34+ e <- P.parseModulesFromFiles (fromMaybe "") <$> mapM (fmap (first Just) . parseFile) (nub input)
35+ case e of
36+ Left err -> do
37+ U.hPutStr stderr $ show err
38+ exitFailure
39+ Right ms -> do
40+ U.putStrLn . runDocs $ (renderModules showHierarchy) (map snd ms)
41+ exitSuccess
42+
43+parseFile :: FilePath -> IO (FilePath, String)
44+parseFile input = (,) input <$> U.readFile input
45+
46+type Docs = Writer [String] ()
47+
48+runDocs :: Docs -> String
49+runDocs = unlines . execWriter
50+
51+spacer :: Docs
52+spacer = tell [""]
53+
54+headerLevel :: Int -> String -> Docs
55+headerLevel level hdr = tell [replicate level '#' ++ ' ' : hdr]
56+
57+atIndent :: Int -> String -> Docs
58+atIndent indent text =
59+ let ls = lines text in
60+ forM_ ls $ \l -> tell [replicate indent ' ' ++ l]
61+
62+renderModules :: Bool -> [P.Module] -> Docs
63+renderModules showHierarchy ms = do
64+ headerLevel 1 "Module Documentation"
65+ spacer
66+ mapM_ (renderModule showHierarchy) ms
67+
68+renderModule :: Bool -> P.Module -> Docs
69+renderModule showHierarchy (P.Module moduleName ds exps) =
70+ let exported = filter (isExported exps) ds
71+ hasTypes = any isTypeDeclaration ds
72+ hasTypeclasses = any isTypeClassDeclaration ds
73+ hasTypeclassInstances = any isTypeInstanceDeclaration ds
74+ hasValues = any isValueDeclaration ds
75+ in do
76+ headerLevel 2 $ "Module " ++ P.runModuleName moduleName
77+ spacer
78+ when hasTypes $ do
79+ headerLevel 3 "Types"
80+ spacer
81+ renderTopLevel exps (filter isTypeDeclaration exported)
82+ spacer
83+ when hasTypeclasses $ do
84+ headerLevel 3 "Type Classes"
85+ spacer
86+ when showHierarchy $ do
87+ renderTypeclassImage moduleName
88+ spacer
89+ renderTopLevel exps (filter isTypeClassDeclaration exported)
90+ spacer
91+ when hasTypeclassInstances $ do
92+ headerLevel 3 "Type Class Instances"
93+ spacer
94+ renderTopLevel exps (filter isTypeInstanceDeclaration ds)
95+ spacer
96+ when hasValues $ do
97+ headerLevel 3 "Values"
98+ spacer
99+ renderTopLevel exps (filter isValueDeclaration exported)
100+ spacer
101+
102+isExported :: Maybe [P.DeclarationRef] -> P.Declaration -> Bool
103+isExported Nothing _ = True
104+isExported _ P.TypeInstanceDeclaration{} = True
105+isExported exps (P.PositionedDeclaration _ d) = isExported exps d
106+isExported (Just exps) decl = any (matches decl) exps
107+ where
108+ matches (P.TypeDeclaration ident _) (P.ValueRef ident') = ident == ident'
109+ matches (P.ExternDeclaration _ ident _ _) (P.ValueRef ident') = ident == ident'
110+ matches (P.DataDeclaration _ ident _ _) (P.TypeRef ident' _) = ident == ident'
111+ matches (P.ExternDataDeclaration ident _) (P.TypeRef ident' _) = ident == ident'
112+ matches (P.TypeSynonymDeclaration ident _ _) (P.TypeRef ident' _) = ident == ident'
113+ matches (P.TypeClassDeclaration ident _ _ _) (P.TypeClassRef ident') = ident == ident'
114+ matches (P.PositionedDeclaration _ d) r = d `matches` r
115+ matches d (P.PositionedDeclarationRef _ r) = d `matches` r
116+ matches _ _ = False
117+
118+isDctorExported :: P.ProperName -> Maybe [P.DeclarationRef] -> P.ProperName -> Bool
119+isDctorExported _ Nothing _ = True
120+isDctorExported ident (Just exps) ctor = test `any` exps
121+ where
122+ test (P.PositionedDeclarationRef _ d) = test d
123+ test (P.TypeRef ident' Nothing) = ident == ident'
124+ test (P.TypeRef ident' (Just ctors)) = ident == ident' && ctor `elem` ctors
125+ test _ = False
126+
127+renderTopLevel :: Maybe [P.DeclarationRef] -> [P.Declaration] -> Docs
128+renderTopLevel exps decls = forM_ (sortBy (compare `on` getName) decls) $ \decl -> do
129+ renderDeclaration 4 exps decl
130+ spacer
131+
132+renderTypeclassImage :: P.ModuleName -> Docs
133+renderTypeclassImage name =
134+ let name' = P.runModuleName name
135+ in tell ["![" ++ name' ++ "](images/" ++ name' ++ ".png)"]
136+
137+renderDeclaration :: Int -> Maybe [P.DeclarationRef] -> P.Declaration -> Docs
138+renderDeclaration n _ (P.TypeDeclaration ident ty) =
139+ atIndent n $ show ident ++ " :: " ++ prettyPrintType' ty
140+renderDeclaration n _ (P.ExternDeclaration _ ident _ ty) =
141+ atIndent n $ show ident ++ " :: " ++ prettyPrintType' ty
142+renderDeclaration n exps (P.DataDeclaration dtype name args ctors) = do
143+ let
144+ typeApp = foldl P.TypeApp (P.TypeConstructor (P.Qualified Nothing name)) (map toTypeVar args)
145+ typeName = prettyPrintType' typeApp
146+ exported = filter (isDctorExported name exps . fst) ctors
147+ atIndent n $ show dtype ++ " " ++ typeName ++ (if null exported then "" else " where")
148+ forM_ exported $ \(ctor, tys) ->
149+ let ctorTy = foldr P.function typeApp tys
150+ in atIndent (n + 2) $ P.runProperName ctor ++ " :: " ++ prettyPrintType' ctorTy
151+renderDeclaration n _ (P.ExternDataDeclaration name kind) =
152+ atIndent n $ "data " ++ P.runProperName name ++ " :: " ++ P.prettyPrintKind kind
153+renderDeclaration n _ (P.TypeSynonymDeclaration name args ty) = do
154+ let
155+ typeApp = foldl P.TypeApp (P.TypeConstructor (P.Qualified Nothing name)) (map toTypeVar args)
156+ typeName = prettyPrintType' typeApp
157+ atIndent n $ "type " ++ typeName ++ " = " ++ prettyPrintType' ty
158+renderDeclaration n exps (P.TypeClassDeclaration name args implies ds) = do
159+ let impliesText = case implies of
160+ [] -> ""
161+ is -> "(" ++ intercalate ", " (map (\(pn, tys') -> show pn ++ " " ++ unwords (map P.prettyPrintTypeAtom tys')) is) ++ ") <= "
162+ classApp = foldl P.TypeApp (P.TypeConstructor (P.Qualified Nothing name)) (map toTypeVar args)
163+ className = prettyPrintType' classApp
164+ atIndent n $ "class " ++ impliesText ++ className ++ " where"
165+ mapM_ (renderDeclaration (n + 2) exps) ds
166+renderDeclaration n _ (P.TypeInstanceDeclaration name constraints className tys _) = do
167+ let constraintsText = case constraints of
168+ [] -> ""
169+ cs -> "(" ++ intercalate ", " (map (\(pn, tys') -> show pn ++ " " ++ unwords (map P.prettyPrintTypeAtom tys')) cs) ++ ") => "
170+ atIndent n $ "instance " ++ show name ++ " :: " ++ constraintsText ++ show className ++ " " ++ unwords (map P.prettyPrintTypeAtom tys)
171+renderDeclaration n exps (P.PositionedDeclaration _ d) =
172+ renderDeclaration n exps d
173+renderDeclaration _ _ _ = return ()
174+
175+toTypeVar :: (String, Maybe P.Kind) -> P.Type
176+toTypeVar (s, Nothing) = P.TypeVar s
177+toTypeVar (s, Just k) = P.KindedType (P.TypeVar s) k
178+
179+prettyPrintType' :: P.Type -> String
180+prettyPrintType' = P.prettyPrintType . P.everywhereOnTypes dePrim
181+ where
182+ dePrim ty@(P.TypeConstructor (P.Qualified _ name))
183+ | ty == P.tyBoolean || ty == P.tyNumber || ty == P.tyString =
184+ P.TypeConstructor $ P.Qualified Nothing name
185+ dePrim other = other
186+
187+getName :: P.Declaration -> String
188+getName (P.TypeDeclaration ident _) = show ident
189+getName (P.ExternDeclaration _ ident _ _) = show ident
190+getName (P.DataDeclaration _ name _ _) = P.runProperName name
191+getName (P.ExternDataDeclaration name _) = P.runProperName name
192+getName (P.TypeSynonymDeclaration name _ _) = P.runProperName name
193+getName (P.TypeClassDeclaration name _ _ _) = P.runProperName name
194+getName (P.TypeInstanceDeclaration name _ _ _ _) = show name
195+getName (P.PositionedDeclaration _ d) = getName d
196+getName _ = error "Invalid argument to getName"
197+
198+isValueDeclaration :: P.Declaration -> Bool
199+isValueDeclaration P.TypeDeclaration{} = True
200+isValueDeclaration P.ExternDeclaration{} = True
201+isValueDeclaration (P.PositionedDeclaration _ d) = isValueDeclaration d
202+isValueDeclaration _ = False
203+
204+isTypeDeclaration :: P.Declaration -> Bool
205+isTypeDeclaration P.DataDeclaration{} = True
206+isTypeDeclaration P.ExternDataDeclaration{} = True
207+isTypeDeclaration P.TypeSynonymDeclaration{} = True
208+isTypeDeclaration (P.PositionedDeclaration _ d) = isTypeDeclaration d
209+isTypeDeclaration _ = False
210+
211+isTypeClassDeclaration :: P.Declaration -> Bool
212+isTypeClassDeclaration P.TypeClassDeclaration{} = True
213+isTypeClassDeclaration (P.PositionedDeclaration _ d) = isTypeClassDeclaration d
214+isTypeClassDeclaration _ = False
215+
216+isTypeInstanceDeclaration :: P.Declaration -> Bool
217+isTypeInstanceDeclaration P.TypeInstanceDeclaration{} = True
218+isTypeInstanceDeclaration (P.PositionedDeclaration _ d) = isTypeInstanceDeclaration d
219+isTypeInstanceDeclaration _ = False
220+
221+inputFiles :: Term [FilePath]
222+inputFiles = value $ posAny [] $ posInfo { posName = "file(s)", posDoc = "The input .purs file(s)" }
223+
224+includeHeirarcy :: Term Bool
225+includeHeirarcy = value $ flag $ (optInfo [ "h", "hierarchy-images" ]) { optDoc = "Include markdown for type class hierarchy images in the output." }
226+
227+term :: Term (IO ())
228+term = docgen <$> includeHeirarcy <*> inputFiles
229+
230+termInfo :: TermInfo
231+termInfo = defTI
232+ { termName = "psc-docs"
233+ , version = showVersion Paths.version
234+ , termDoc = "Generate Markdown documentation from PureScript extern files"
235+ }
236+
237+main :: IO ()
238+main = run (term, termInfo)
psc-make/Main.hsnew file+140
@@ -0,0 +1,140 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Main
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+--
13+-----------------------------------------------------------------------------
14+
15+{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, TupleSections, RecordWildCards #-}
16+
17+module Main where
18+
19+import Control.Applicative
20+import Control.Monad.Error
21+
22+import Data.Bool (bool)
23+import Data.Version (showVersion)
24+
25+import System.Console.CmdTheLine
26+import System.Directory
27+ (doesFileExist, getModificationTime, createDirectoryIfMissing)
28+import System.FilePath (takeDirectory)
29+import System.Exit (exitSuccess, exitFailure)
30+import System.IO.Error (tryIOError)
31+
32+import qualified Language.PureScript as P
33+import qualified Paths_purescript as Paths
34+import qualified System.IO.UTF8 as U
35+
36+data InputOptions = InputOptions
37+ { ioNoPrelude :: Bool
38+ , ioInputFiles :: [FilePath]
39+ }
40+
41+readInput :: InputOptions -> IO [(Either P.RebuildPolicy FilePath, String)]
42+readInput InputOptions{..} = do
43+ content <- forM ioInputFiles $ \inputFile -> (Right inputFile, ) <$> U.readFile inputFile
44+ return $ bool ((Left P.RebuildNever, P.prelude) :) id ioNoPrelude content
45+
46+newtype Make a = Make { unMake :: ErrorT String IO a } deriving (Functor, Applicative, Monad, MonadIO, MonadError String)
47+
48+runMake :: Make a -> IO (Either String a)
49+runMake = runErrorT . unMake
50+
51+makeIO :: IO a -> Make a
52+makeIO = Make . ErrorT . fmap (either (Left . show) Right) . tryIOError
53+
54+instance P.MonadMake Make where
55+ getTimestamp path = makeIO $ do
56+ exists <- doesFileExist path
57+ case exists of
58+ True -> Just <$> getModificationTime path
59+ False -> return Nothing
60+ readTextFile path = makeIO $ do
61+ U.putStrLn $ "Reading " ++ path
62+ U.readFile path
63+ writeTextFile path text = makeIO $ do
64+ mkdirp path
65+ U.putStrLn $ "Writing " ++ path
66+ U.writeFile path text
67+ liftError = either throwError return
68+ progress = makeIO . U.putStrLn
69+
70+compile :: [FilePath] -> FilePath -> P.Options P.Make -> Bool -> IO ()
71+compile input outputDir opts usePrefix = do
72+ modules <- P.parseModulesFromFiles (either (const "") id) <$> readInput (InputOptions (P.optionsNoPrelude opts) input)
73+ case modules of
74+ Left err -> do
75+ U.print err
76+ exitFailure
77+ Right ms -> do
78+ e <- runMake $ P.make outputDir opts ms prefix
79+ case e of
80+ Left err -> do
81+ U.putStrLn err
82+ exitFailure
83+ Right _ -> do
84+ exitSuccess
85+ where
86+ prefix = if usePrefix
87+ then ["Generated by psc-make version " ++ showVersion Paths.version]
88+ else []
89+
90+mkdirp :: FilePath -> IO ()
91+mkdirp = createDirectoryIfMissing True . takeDirectory
92+
93+inputFiles :: Term [FilePath]
94+inputFiles = value $ posAny [] $ posInfo
95+ { posDoc = "The input .ps files" }
96+
97+outputDirectory :: Term FilePath
98+outputDirectory = value $ opt "output" $ (optInfo [ "o", "output" ])
99+ { optDoc = "The output directory" }
100+
101+noTco :: Term Bool
102+noTco = value $ flag $ (optInfo [ "no-tco" ])
103+ { optDoc = "Disable tail call optimizations" }
104+
105+noPrelude :: Term Bool
106+noPrelude = value $ flag $ (optInfo [ "no-prelude" ])
107+ { optDoc = "Omit the Prelude" }
108+
109+noMagicDo :: Term Bool
110+noMagicDo = value $ flag $ (optInfo [ "no-magic-do" ])
111+ { optDoc = "Disable the optimization that overloads the do keyword to generate efficient code specifically for the Eff monad." }
112+
113+noOpts :: Term Bool
114+noOpts = value $ flag $ (optInfo [ "no-opts" ])
115+ { optDoc = "Skip the optimization phase." }
116+
117+verboseErrors :: Term Bool
118+verboseErrors = value $ flag $ (optInfo [ "v", "verbose-errors" ])
119+ { optDoc = "Display verbose error messages" }
120+
121+options :: Term (P.Options P.Make)
122+options = P.Options <$> noPrelude <*> noTco <*> noMagicDo <*> pure Nothing <*> noOpts <*> verboseErrors <*> pure P.MakeOptions
123+
124+noPrefix :: Term Bool
125+noPrefix = value $ flag $ (optInfo ["p", "no-prefix" ])
126+ { optDoc = "Do not include comment header"}
127+
128+term :: Term (IO ())
129+term = compile <$> inputFiles <*> outputDirectory <*> options <*> (not <$> noPrefix)
130+
131+termInfo :: TermInfo
132+termInfo = defTI
133+ { termName = "psc-make"
134+ , version = showVersion Paths.version
135+ , termDoc = "Compiles PureScript to Javascript"
136+ }
137+
138+main :: IO ()
139+main = run (term, termInfo)
140+
psc/Main.hsnew file+150
@@ -0,0 +1,150 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Main
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+--
13+-----------------------------------------------------------------------------
14+
15+{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, TupleSections, RecordWildCards #-}
16+
17+module Main where
18+
19+import Control.Applicative
20+import Control.Monad.Error
21+
22+import Data.Bool (bool)
23+import Data.Maybe (fromMaybe)
24+import Data.Version (showVersion)
25+
26+import System.Console.CmdTheLine
27+import System.Directory (createDirectoryIfMissing)
28+import System.FilePath (takeDirectory)
29+import System.Exit (exitSuccess, exitFailure)
30+import System.IO (stderr)
31+
32+import qualified Language.PureScript as P
33+import qualified Paths_purescript as Paths
34+import qualified System.IO.UTF8 as U
35+
36+data InputOptions = InputOptions
37+ { ioNoPrelude :: Bool
38+ , ioUseStdIn :: Bool
39+ , ioInputFiles :: [FilePath]
40+ }
41+
42+readInput :: InputOptions -> IO [(Maybe FilePath, String)]
43+readInput InputOptions{..}
44+ | ioUseStdIn = return . (Nothing ,) <$> getContents
45+ | otherwise = do content <- forM ioInputFiles $ \inputFile -> (Just inputFile, ) <$> U.readFile inputFile
46+ return $ bool ((Nothing, P.prelude) :) id ioNoPrelude content
47+
48+compile :: P.Options P.Compile -> Bool -> [FilePath] -> Maybe FilePath -> Maybe FilePath -> Bool -> IO ()
49+compile opts stdin input output externs usePrefix = do
50+ modules <- P.parseModulesFromFiles (fromMaybe "") <$> readInput (InputOptions (P.optionsNoPrelude opts) stdin input)
51+ case modules of
52+ Left err -> do
53+ U.hPutStr stderr $ show err
54+ exitFailure
55+ Right ms -> do
56+ case P.compile opts (map snd ms) prefix of
57+ Left err -> do
58+ U.hPutStrLn stderr err
59+ exitFailure
60+ Right (js, exts, _) -> do
61+ case output of
62+ Just path -> mkdirp path >> U.writeFile path js
63+ Nothing -> U.putStrLn js
64+ case externs of
65+ Just path -> mkdirp path >> U.writeFile path exts
66+ Nothing -> return ()
67+ exitSuccess
68+ where
69+ prefix = if usePrefix
70+ then ["Generated by psc version " ++ showVersion Paths.version]
71+ else []
72+
73+mkdirp :: FilePath -> IO ()
74+mkdirp = createDirectoryIfMissing True . takeDirectory
75+
76+useStdIn :: Term Bool
77+useStdIn = value . flag $ (optInfo [ "s", "stdin" ])
78+ { optDoc = "Read from standard input" }
79+
80+inputFiles :: Term [FilePath]
81+inputFiles = value $ posAny [] $ posInfo
82+ { posDoc = "The input .ps files" }
83+
84+outputFile :: Term (Maybe FilePath)
85+outputFile = value $ opt Nothing $ (optInfo [ "o", "output" ])
86+ { optDoc = "The output .js file" }
87+
88+externsFile :: Term (Maybe FilePath)
89+externsFile = value $ opt Nothing $ (optInfo [ "e", "externs" ])
90+ { optDoc = "The output .e.ps file" }
91+
92+noTco :: Term Bool
93+noTco = value $ flag $ (optInfo [ "no-tco" ])
94+ { optDoc = "Disable tail call optimizations" }
95+
96+noPrelude :: Term Bool
97+noPrelude = value $ flag $ (optInfo [ "no-prelude" ])
98+ { optDoc = "Omit the Prelude" }
99+
100+noMagicDo :: Term Bool
101+noMagicDo = value $ flag $ (optInfo [ "no-magic-do" ])
102+ { optDoc = "Disable the optimization that overloads the do keyword to generate efficient code specifically for the Eff monad." }
103+
104+runMain :: Term (Maybe String)
105+runMain = value $ defaultOpt (Just "Main") Nothing $ (optInfo [ "main" ])
106+ { optDoc = "Generate code to run the main method in the specified module." }
107+
108+noOpts :: Term Bool
109+noOpts = value $ flag $ (optInfo [ "no-opts" ])
110+ { optDoc = "Skip the optimization phase." }
111+
112+browserNamespace :: Term String
113+browserNamespace = value $ opt "PS" $ (optInfo [ "browser-namespace" ])
114+ { optDoc = "Specify the namespace that PureScript modules will be exported to when running in the browser." }
115+
116+dceModules :: Term [String]
117+dceModules = value $ optAll [] $ (optInfo [ "m", "module" ])
118+ { optDoc = "Enables dead code elimination, all code which is not a transitive dependency of a specified module will be removed. This argument can be used multiple times." }
119+
120+codeGenModules :: Term [String]
121+codeGenModules = value $ optAll [] $ (optInfo [ "codegen" ])
122+ { optDoc = "A list of modules for which Javascript and externs should be generated. This argument can be used multiple times." }
123+
124+verboseErrors :: Term Bool
125+verboseErrors = value $ flag $ (optInfo [ "v", "verbose-errors" ])
126+ { optDoc = "Display verbose error messages" }
127+
128+noPrefix :: Term Bool
129+noPrefix = value $ flag $ (optInfo ["no-prefix" ])
130+ { optDoc = "Do not include comment header"}
131+
132+options :: Term (P.Options P.Compile)
133+options = P.Options <$> noPrelude <*> noTco <*> noMagicDo <*> runMain <*> noOpts <*> verboseErrors <*> additionalOptions
134+ where
135+ additionalOptions = P.CompileOptions <$> browserNamespace <*> dceModules <*> codeGenModules
136+
137+term :: Term (IO ())
138+term = compile <$> options <*> useStdIn <*> inputFiles <*> outputFile <*> externsFile <*> (not <$> noPrefix)
139+
140+termInfo :: TermInfo
141+termInfo = defTI
142+ { termName = "psc"
143+ , version = showVersion Paths.version
144+ , termDoc = "Compiles PureScript to Javascript"
145+ }
146+
147+main :: IO ()
148+main = run (term, termInfo)
149+
150+
psci/Commands.hsnew file+84
@@ -0,0 +1,84 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Commands
4+-- Copyright : (c) Phil Freeman 2014
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- Commands for PSCI.
13+--
14+-----------------------------------------------------------------------------
15+
16+module Commands where
17+
18+import Language.PureScript
19+
20+-- |
21+-- Valid Meta-commands for PSCI
22+--
23+data Command
24+ -- |
25+ -- A purescript expression
26+ --
27+ = Expression Expr
28+ -- |
29+ -- Show the help command
30+ --
31+ | Help
32+ -- |
33+ -- Import a module from a loaded file
34+ --
35+ | Import ModuleName
36+ -- |
37+ -- Browse a module
38+ --
39+ | Browse ModuleName
40+ -- |
41+ -- Load a file for use with importing
42+ --
43+ | LoadFile FilePath
44+ -- |
45+ -- Exit PSCI
46+ --
47+ | Quit
48+ -- |
49+ -- Reset the state of the REPL
50+ --
51+ | Reset
52+ -- |
53+ -- Binds a value to a name
54+ --
55+ | Let (Expr -> Expr)
56+ -- |
57+ -- Find the type of an expression
58+ --
59+ | TypeOf Expr
60+ -- |
61+ -- Find the kind of an expression
62+ --
63+ | KindOf Type
64+ -- |
65+ -- Show command
66+ --
67+ | Show String
68+
69+-- |
70+-- The help menu.
71+--
72+help :: [[String]]
73+help =
74+ [ [":? ", "Show this help menu"]
75+ , [":i <module> ", "Import <module> for use in PSCI"]
76+ , [":b <module> ", "Browse <module>"]
77+ , [":m <file> ", "Load <file> for importing"]
78+ , [":q ", "Quit PSCi"]
79+ , [":r ", "Reset"]
80+ , [":s import ", "Show imported modules"]
81+ , [":s loaded ", "Show loaded modules"]
82+ , [":t <expr> ", "Show the type of <expr>"]
83+ , [":k <type> ", "Show the kind of <type>"]
84+ ]
psci/Main.hsnew file+542
@@ -0,0 +1,542 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Main
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- PureScript Compiler Interactive.
13+--
14+-----------------------------------------------------------------------------
15+
16+{-# LANGUAGE DataKinds, DoAndIfThenElse, FlexibleContexts, GeneralizedNewtypeDeriving #-}
17+
18+module Main where
19+
20+import Data.Foldable (traverse_)
21+import Data.List (intercalate, isPrefixOf, nub, sortBy, sort)
22+import Data.Maybe (mapMaybe)
23+import Data.Traversable (traverse)
24+import Data.Version (showVersion)
25+import qualified Data.Map as M
26+
27+import Control.Applicative
28+import Control.Monad
29+import Control.Monad.Error (ErrorT(..), MonadError)
30+import Control.Monad.Error.Class (MonadError(..))
31+import Control.Monad.Trans.Class
32+import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)
33+import Control.Monad.Trans.State.Strict
34+import qualified Control.Monad.Trans.State.Lazy as L
35+
36+import System.Console.Haskeline
37+import System.Directory (createDirectoryIfMissing, getModificationTime, doesFileExist, findExecutable, getHomeDirectory, getCurrentDirectory)
38+import System.Exit
39+import System.FilePath (pathSeparator, takeDirectory, (</>), isPathSeparator)
40+import System.IO.Error (tryIOError)
41+import System.Process (readProcessWithExitCode)
42+import qualified System.Console.CmdTheLine as Cmd
43+import qualified System.IO.UTF8 as U (writeFile, putStrLn, print, readFile)
44+
45+import Text.Parsec (ParseError)
46+
47+import qualified Language.PureScript as P
48+import qualified Language.PureScript.AST as D
49+import qualified Language.PureScript.Names as N
50+import qualified Paths_purescript as Paths
51+
52+import Commands
53+import Parser
54+
55+-- |
56+-- The PSCI state.
57+-- Holds a list of imported modules, loaded files, and partial let bindings.
58+-- The let bindings are partial,
59+-- because it makes more sense to apply the binding to the final evaluated expression.
60+--
61+data PSCiState = PSCiState
62+ { psciImportedFilenames :: [FilePath]
63+ , psciImportedModuleNames :: [P.ModuleName]
64+ , psciLoadedModules :: [(Either P.RebuildPolicy FilePath, P.Module)]
65+ , psciLetBindings :: [P.Expr -> P.Expr]
66+ }
67+
68+-- State helpers
69+
70+-- |
71+-- Updates the state to have more imported modules.
72+--
73+updateImportedFiles :: FilePath -> PSCiState -> PSCiState
74+updateImportedFiles filename st = st { psciImportedFilenames = filename : psciImportedFilenames st }
75+
76+-- |
77+-- Updates the state to have more imported modules.
78+--
79+updateImports :: P.ModuleName -> PSCiState -> PSCiState
80+updateImports name st = st { psciImportedModuleNames = name : psciImportedModuleNames st }
81+
82+-- |
83+-- Updates the state to have more loaded files.
84+--
85+updateModules :: [(Either P.RebuildPolicy FilePath, P.Module)] -> PSCiState -> PSCiState
86+updateModules modules st = st { psciLoadedModules = psciLoadedModules st ++ modules }
87+
88+-- |
89+-- Updates the state to have more let bindings.
90+--
91+updateLets :: (P.Expr -> P.Expr) -> PSCiState -> PSCiState
92+updateLets name st = st { psciLetBindings = name : psciLetBindings st }
93+
94+-- File helpers
95+-- |
96+-- Load the necessary modules.
97+--
98+defaultImports :: [P.ModuleName]
99+defaultImports = [P.ModuleName [P.ProperName "Prelude"]]
100+
101+-- |
102+-- Locates the node executable.
103+-- Checks for either @nodejs@ or @node@.
104+--
105+findNodeProcess :: IO (Maybe String)
106+findNodeProcess = runMaybeT . msum $ map (MaybeT . findExecutable) names
107+ where names = ["nodejs", "node"]
108+
109+-- |
110+-- Grabs the filename where the history is stored.
111+--
112+getHistoryFilename :: IO FilePath
113+getHistoryFilename = do
114+ home <- getHomeDirectory
115+ let filename = home </> ".purescript" </> "psci_history"
116+ mkdirp filename
117+ return filename
118+
119+-- |
120+-- Loads a file for use with imports.
121+--
122+loadModule :: FilePath -> IO (Either String [P.Module])
123+loadModule filename = either (Left . show) Right . P.runIndentParser filename P.parseModules <$> U.readFile filename
124+
125+-- |
126+-- Load all modules, including the Prelude
127+--
128+loadAllModules :: [FilePath] -> IO (Either ParseError [(Either P.RebuildPolicy FilePath, P.Module)])
129+loadAllModules files = do
130+ filesAndContent <- forM files $ \filename -> do
131+ content <- U.readFile filename
132+ return (Right filename, content)
133+ return $ P.parseModulesFromFiles (either (const "") id) $ (Left P.RebuildNever, P.prelude) : filesAndContent
134+
135+
136+-- |
137+-- Expands tilde in path.
138+--
139+expandTilde :: FilePath -> IO FilePath
140+expandTilde ('~':p:rest) | isPathSeparator p = (</> rest) <$> getHomeDirectory
141+expandTilde p = return p
142+-- Messages
143+
144+-- |
145+-- The help message.
146+--
147+helpMessage :: String
148+helpMessage = "The following commands are available:\n\n " ++
149+ intercalate "\n " (map (intercalate " ") help)
150+
151+-- |
152+-- The welcome prologue.
153+--
154+prologueMessage :: String
155+prologueMessage = intercalate "\n"
156+ [ " ____ ____ _ _ "
157+ , "| _ \\ _ _ _ __ ___/ ___| ___ _ __(_)_ __ | |_ "
158+ , "| |_) | | | | '__/ _ \\___ \\ / __| '__| | '_ \\| __|"
159+ , "| __/| |_| | | | __/___) | (__| | | | |_) | |_ "
160+ , "|_| \\__,_|_| \\___|____/ \\___|_| |_| .__/ \\__|"
161+ , " |_| "
162+ , ""
163+ , ":? shows help"
164+ , ""
165+ , "Expressions are terminated using Ctrl+D"
166+ ]
167+
168+-- |
169+-- The quit message.
170+--
171+quitMessage :: String
172+quitMessage = "See ya!"
173+
174+-- Haskeline completions
175+
176+-- |
177+-- Loads module, function, and file completions.
178+--
179+completion :: CompletionFunc (StateT PSCiState IO)
180+completion = completeWord Nothing " \t\n\r" findCompletions
181+ where
182+ findCompletions :: String -> StateT PSCiState IO [Completion]
183+ findCompletions str = do
184+ ms <- map snd . psciLoadedModules <$> get
185+ files <- listFiles str
186+ let matches = filter (isPrefixOf str) (names ms)
187+ return $ sortBy sorter $ map simpleCompletion matches ++ files
188+ getDeclName :: Maybe [P.DeclarationRef] -> P.Declaration -> Maybe P.Ident
189+ getDeclName Nothing (P.ValueDeclaration ident _ _ _) = Just ident
190+ getDeclName (Just exts) (P.ValueDeclaration ident _ _ _) | isExported = Just ident
191+ where
192+ isExported = any exports exts
193+ exports (P.ValueRef ident') = ident == ident'
194+ exports (P.PositionedDeclarationRef _ r) = exports r
195+ exports _ = False
196+ getDeclName exts (P.PositionedDeclaration _ d) = getDeclName exts d
197+ getDeclName _ _ = Nothing
198+ names :: [P.Module] -> [String]
199+ names ms = nub [ show qual
200+ | P.Module moduleName ds exts <- ms
201+ , ident <- mapMaybe (getDeclName exts) ds
202+ , qual <- [ P.Qualified Nothing ident
203+ , P.Qualified (Just moduleName) ident]
204+ ]
205+ sorter :: Completion -> Completion -> Ordering
206+ sorter (Completion _ d1 _) (Completion _ d2 _) = compare d1 d2
207+
208+-- Compilation
209+
210+-- | Compilation options.
211+--
212+options :: P.Options P.Make
213+options = P.Options False False False Nothing False False P.MakeOptions
214+
215+-- |
216+-- PSCI monad
217+--
218+newtype PSCI a = PSCI { runPSCI :: InputT (StateT PSCiState IO) a } deriving (Functor, Applicative, Monad)
219+
220+psciIO :: IO a -> PSCI a
221+psciIO io = PSCI (lift (lift io))
222+
223+newtype Make a = Make { unMake :: ErrorT String IO a } deriving (Functor, Applicative, Monad, MonadError String)
224+
225+runMake :: Make a -> IO (Either String a)
226+runMake = runErrorT . unMake
227+
228+makeIO :: IO a -> Make a
229+makeIO = Make . ErrorT . fmap (either (Left . show) Right) . tryIOError
230+
231+instance P.MonadMake Make where
232+ getTimestamp path = makeIO $ do
233+ exists <- doesFileExist path
234+ if exists
235+ then Just <$> getModificationTime path
236+ else return Nothing
237+ readTextFile path = makeIO $ U.readFile path
238+ writeTextFile path text = makeIO $ do
239+ mkdirp path
240+ U.writeFile path text
241+ liftError = either throwError return
242+ progress s = unless (s == "Compiling $PSCI") $ makeIO . U.putStrLn $ s
243+
244+mkdirp :: FilePath -> IO ()
245+mkdirp = createDirectoryIfMissing True . takeDirectory
246+
247+-- |
248+-- Makes a volatile module to execute the current expression.
249+--
250+createTemporaryModule :: Bool -> PSCiState -> P.Expr -> P.Module
251+createTemporaryModule exec PSCiState{psciImportedModuleNames = imports, psciLetBindings = lets} value =
252+ let
253+ moduleName = P.ModuleName [P.ProperName "$PSCI"]
254+ importDecl m = P.ImportDeclaration m P.Unqualified Nothing
255+ traceModule = P.ModuleName [P.ProperName "Debug", P.ProperName "Trace"]
256+ trace = P.Var (P.Qualified (Just traceModule) (P.Ident "print"))
257+ itValue = foldl (\x f -> f x) value lets
258+ mainValue = P.App trace (P.Var (P.Qualified Nothing (P.Ident "it")))
259+ itDecl = P.ValueDeclaration (P.Ident "it") P.Value [] $ Right itValue
260+ mainDecl = P.ValueDeclaration (P.Ident "main") P.Value [] $ Right mainValue
261+ decls = if exec then [itDecl, mainDecl] else [itDecl]
262+ in
263+ P.Module moduleName ((importDecl `map` imports) ++ decls) Nothing
264+
265+-- |
266+-- Makes a volatile module to hold a non-qualified type synonym for a fully-qualified data type declaration.
267+--
268+createTemporaryModuleForKind :: PSCiState -> P.Type -> P.Module
269+createTemporaryModuleForKind PSCiState{psciImportedModuleNames = imports} typ =
270+ let
271+ moduleName = P.ModuleName [P.ProperName "$PSCI"]
272+ importDecl m = P.ImportDeclaration m P.Unqualified Nothing
273+ itDecl = P.TypeSynonymDeclaration (P.ProperName "IT") [] typ
274+ in
275+ P.Module moduleName ((importDecl `map` imports) ++ [itDecl]) Nothing
276+
277+-- |
278+-- Makes a volatile module to execute the current imports.
279+--
280+createTemporaryModuleForImports :: PSCiState -> P.Module
281+createTemporaryModuleForImports PSCiState{psciImportedModuleNames = imports} =
282+ let
283+ moduleName = P.ModuleName [P.ProperName "$PSCI"]
284+ importDecl m = P.ImportDeclaration m P.Unqualified Nothing
285+ in
286+ P.Module moduleName (importDecl `map` imports) Nothing
287+
288+modulesDir :: FilePath
289+modulesDir = ".psci_modules" ++ pathSeparator : "node_modules"
290+
291+indexFile :: FilePath
292+indexFile = ".psci_modules" ++ pathSeparator : "index.js"
293+
294+-- |
295+-- Takes a value declaration and evaluates it with the current state.
296+--
297+handleDeclaration :: P.Expr -> PSCI ()
298+handleDeclaration value = do
299+ st <- PSCI $ lift get
300+ let m = createTemporaryModule True st value
301+ e <- psciIO . runMake $ P.make modulesDir options (psciLoadedModules st ++ [(Left P.RebuildAlways, m)]) []
302+ case e of
303+ Left err -> PSCI $ outputStrLn err
304+ Right _ -> do
305+ psciIO $ writeFile indexFile "require('$PSCI').main();"
306+ process <- psciIO findNodeProcess
307+ result <- psciIO $ traverse (\node -> readProcessWithExitCode node [indexFile] "") process
308+ case result of
309+ Just (ExitSuccess, out, _) -> PSCI $ outputStrLn out
310+ Just (ExitFailure _, _, err) -> PSCI $ outputStrLn err
311+ Nothing -> PSCI $ outputStrLn "Couldn't find node.js"
312+
313+-- |
314+-- Takes a let declaration and updates the environment, then run a make. If the declaration fails,
315+-- restore the pre-let environment.
316+--
317+handleLet :: (P.Expr -> P.Expr) -> PSCI ()
318+handleLet l = do
319+ st <- PSCI $ lift get
320+ let st' = updateLets l st
321+ let m = createTemporaryModule False st' (P.ObjectLiteral [])
322+ e <- psciIO . runMake $ P.make modulesDir options (psciLoadedModules st' ++ [(Left P.RebuildAlways, m)]) []
323+ case e of
324+ Left err -> PSCI $ outputStrLn err
325+ Right _ -> PSCI $ lift (put st')
326+
327+-- |
328+-- Show actual loaded modules in psci.
329+--
330+handleShowLoadedModules :: PSCI ()
331+handleShowLoadedModules = do
332+ PSCiState { psciLoadedModules = loadedModules } <- PSCI $ lift get
333+ psciIO $ readModules loadedModules >>= putStrLn
334+ return ()
335+ where readModules = return . unlines . sort . nub . map toModuleName
336+ toModuleName = N.runModuleName . (\ (D.Module mdName _ _) -> mdName) . snd
337+
338+-- |
339+-- Show the imported modules in psci.
340+--
341+handleShowImportedModules :: PSCI ()
342+handleShowImportedModules = do
343+ PSCiState { psciImportedModuleNames = importedModuleNames } <- PSCI $ lift get
344+ psciIO $ readModules importedModuleNames >>= putStrLn
345+ return ()
346+ where readModules = return . unlines . sort . map N.runModuleName
347+
348+-- |
349+-- Imports a module, preserving the initial state on failure.
350+--
351+handleImport :: P.ModuleName -> PSCI ()
352+handleImport moduleName = do
353+ st <- updateImports moduleName <$> PSCI (lift get)
354+ let m = createTemporaryModuleForImports st
355+ e <- psciIO . runMake $ P.make modulesDir options (psciLoadedModules st ++ [(Left P.RebuildAlways, m)]) []
356+ case e of
357+ Left err -> PSCI $ outputStrLn err
358+ Right _ -> do
359+ PSCI $ lift $ put st
360+ return ()
361+
362+-- |
363+-- Takes a value and prints its type
364+--
365+handleTypeOf :: P.Expr -> PSCI ()
366+handleTypeOf value = do
367+ st <- PSCI $ lift get
368+ let m = createTemporaryModule False st value
369+ e <- psciIO . runMake $ P.make modulesDir options (psciLoadedModules st ++ [(Left P.RebuildAlways, m)]) []
370+ case e of
371+ Left err -> PSCI $ outputStrLn err
372+ Right env' ->
373+ case M.lookup (P.ModuleName [P.ProperName "$PSCI"], P.Ident "it") (P.names env') of
374+ Just (ty, _, _) -> PSCI . outputStrLn . P.prettyPrintType $ ty
375+ Nothing -> PSCI $ outputStrLn "Could not find type"
376+
377+-- |
378+-- Pretty print a module's signatures
379+--
380+printModuleSignatures :: P.ModuleName -> P.Environment -> PSCI ()
381+printModuleSignatures moduleName env =
382+ PSCI $ let namesEnv = P.names env
383+ moduleNamesIdent = (filter ((== moduleName) . fst) . M.keys) namesEnv
384+ in case moduleNamesIdent of
385+ [] -> outputStrLn $ "This module '"++ P.runModuleName moduleName ++"' does not export functions."
386+ _ -> ( outputStrLn
387+ . unlines
388+ . sort
389+ . map (showType . findType namesEnv)) moduleNamesIdent
390+ where findType :: M.Map (P.ModuleName, P.Ident) (P.Type, P.NameKind, P.NameVisibility) -> (P.ModuleName, P.Ident) -> (P.Ident, Maybe (P.Type, P.NameKind, P.NameVisibility))
391+ findType envNames m@(_, mIdent) = (mIdent, M.lookup m envNames)
392+ showType :: (P.Ident, Maybe (P.Type, P.NameKind, P.NameVisibility)) -> String
393+ showType (mIdent, Just (mType, _, _)) = show mIdent ++ " :: " ++ P.prettyPrintType mType
394+ showType _ = error "The impossible happened in printModuleSignatures."
395+
396+-- |
397+-- Browse a module and displays its signature (if module exists).
398+--
399+handleBrowse :: P.ModuleName -> PSCI ()
400+handleBrowse moduleName = do
401+ st <- PSCI $ lift get
402+ let loadedModules = psciLoadedModules st
403+ env <- psciIO . runMake $ P.make modulesDir options loadedModules []
404+ case env of
405+ Left err -> PSCI $ outputStrLn err
406+ Right env' ->
407+ if moduleName `notElem` (nub . map ((\ (P.Module modName _ _ ) -> modName) . snd)) loadedModules
408+ then PSCI $ outputStrLn $ "Module '" ++ N.runModuleName moduleName ++ "' is not valid."
409+ else printModuleSignatures moduleName env'
410+
411+-- |
412+-- Takes a value and prints its kind
413+--
414+handleKindOf :: P.Type -> PSCI ()
415+handleKindOf typ = do
416+ st <- PSCI $ lift get
417+ let m = createTemporaryModuleForKind st typ
418+ mName = P.ModuleName [P.ProperName "$PSCI"]
419+ e <- psciIO . runMake $ P.make modulesDir options (psciLoadedModules st ++ [(Left P.RebuildAlways, m)]) []
420+ case e of
421+ Left err -> PSCI $ outputStrLn err
422+ Right env' ->
423+ case M.lookup (P.Qualified (Just mName) $ P.ProperName "IT") (P.typeSynonyms env') of
424+ Just (_, typ') -> do
425+ let chk = P.CheckState env' 0 0 (Just mName)
426+ k = L.runStateT (P.unCheck (P.kindOf mName typ')) chk
427+ case k of
428+ Left errStack -> PSCI . outputStrLn . P.prettyPrintErrorStack False $ errStack
429+ Right (kind, _) -> PSCI . outputStrLn . P.prettyPrintKind $ kind
430+ Nothing -> PSCI $ outputStrLn "Could not find kind"
431+
432+-- Commands
433+
434+-- |
435+-- Parses the input and returns either a Metacommand or an expression.
436+--
437+getCommand :: Bool -> InputT (StateT PSCiState IO) (Either ParseError (Maybe Command))
438+getCommand singleLineMode = do
439+ firstLine <- getInputLine "> "
440+ case firstLine of
441+ Nothing -> return (Right Nothing)
442+ Just "" -> return (Right Nothing)
443+ Just s | singleLineMode || head s == ':' -> return . either Left (Right . Just) $ parseCommand s
444+ Just s -> either Left (Right . Just) . parseCommand <$> go [s]
445+ where
446+ go :: [String] -> InputT (StateT PSCiState IO) String
447+ go ls = maybe (return . unlines $ reverse ls) (go . (:ls)) =<< getInputLine " "
448+
449+-- |
450+-- Performs an action for each meta-command given, and also for expressions..
451+--
452+handleCommand :: Command -> PSCI ()
453+handleCommand (Expression val) = handleDeclaration val
454+handleCommand Help = PSCI $ outputStrLn helpMessage
455+handleCommand (Import moduleName) = handleImport moduleName
456+handleCommand (Let l) = handleLet l
457+handleCommand (LoadFile filePath) = do
458+ absPath <- psciIO $ expandTilde filePath
459+ exists <- psciIO $ doesFileExist absPath
460+ if exists then do
461+ PSCI . lift $ modify (updateImportedFiles absPath)
462+ m <- psciIO $ loadModule absPath
463+ case m of
464+ Left err -> PSCI $ outputStrLn err
465+ Right mods -> PSCI . lift $ modify (updateModules (map ((,) (Right absPath)) mods))
466+ else
467+ PSCI . outputStrLn $ "Couldn't locate: " ++ filePath
468+handleCommand Reset = do
469+ files <- psciImportedFilenames <$> PSCI (lift get)
470+ modulesOrFirstError <- psciIO $ loadAllModules files
471+ case modulesOrFirstError of
472+ Left err -> psciIO $ print err >> exitFailure
473+ Right modules -> PSCI . lift $ put (PSCiState files defaultImports modules [])
474+handleCommand (TypeOf val) = handleTypeOf val
475+handleCommand (KindOf typ) = handleKindOf typ
476+handleCommand (Browse moduleName) = handleBrowse moduleName
477+handleCommand (Show "loaded") = handleShowLoadedModules
478+handleCommand (Show "import") = handleShowImportedModules
479+handleCommand _ = PSCI $ outputStrLn "Unknown command"
480+
481+singleLineFlag :: Cmd.Term Bool
482+singleLineFlag = Cmd.value $ Cmd.flag $ (Cmd.optInfo ["single-line-mode"])
483+ { Cmd.optName = "Single-line mode"
484+ , Cmd.optDoc = "Run in single-line mode"
485+ }
486+
487+inputFiles :: Cmd.Term [FilePath]
488+inputFiles = Cmd.value $ Cmd.posAny [] $ Cmd.posInfo { Cmd.posName = "file(s)"
489+ , Cmd.posDoc = "Optional .purs files to load on start"
490+ }
491+
492+loadUserConfig :: IO (Maybe [Command])
493+loadUserConfig = do
494+ configFile <- (</> ".psci") <$> getCurrentDirectory
495+ exists <- doesFileExist configFile
496+ if exists
497+ then do
498+ ls <- lines <$> U.readFile configFile
499+ case mapM parseCommand ls of
500+ Left err -> U.print err >> exitFailure
501+ Right cs -> return $ Just cs
502+ else
503+ return Nothing
504+
505+-- |
506+-- The PSCI main loop.
507+--
508+loop :: Bool -> [FilePath] -> IO ()
509+loop singleLineMode files = do
510+ config <- loadUserConfig
511+ modulesOrFirstError <- loadAllModules files
512+ case modulesOrFirstError of
513+ Left err -> print err >> exitFailure
514+ Right modules -> do
515+ historyFilename <- getHistoryFilename
516+ let settings = defaultSettings { historyFile = Just historyFilename }
517+ flip evalStateT (PSCiState files defaultImports modules []) . runInputT (setComplete completion settings) $ do
518+ outputStrLn prologueMessage
519+ traverse_ (mapM_ (runPSCI . handleCommand)) config
520+ go
521+ where
522+ go :: InputT (StateT PSCiState IO) ()
523+ go = do
524+ c <- getCommand singleLineMode
525+ case c of
526+ Left err -> outputStrLn (show err) >> go
527+ Right Nothing -> go
528+ Right (Just Quit) -> outputStrLn quitMessage
529+ Right (Just c') -> runPSCI (handleCommand c') >> go
530+
531+term :: Cmd.Term (IO ())
532+term = loop <$> singleLineFlag <*> inputFiles
533+
534+termInfo :: Cmd.TermInfo
535+termInfo = Cmd.defTI
536+ { Cmd.termName = "psci"
537+ , Cmd.version = showVersion Paths.version
538+ , Cmd.termDoc = "Interactive mode for PureScript"
539+ }
540+
541+main :: IO ()
542+main = Cmd.run (term, termInfo)
psci/Parser.hsnew file+112
@@ -0,0 +1,112 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Parser
4+-- Copyright : (c) Phil Freeman 2014
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- Parser for PSCI.
13+--
14+-----------------------------------------------------------------------------
15+
16+module Parser (
17+ parseCommand
18+ ) where
19+
20+import Commands
21+
22+import Data.Char (isSpace)
23+
24+import Control.Applicative hiding (many)
25+
26+import Text.Parsec hiding ((<|>))
27+
28+import qualified Language.PureScript as P
29+import qualified Language.PureScript.Parser.Common as C (mark, same)
30+
31+-- |
32+-- PSCI version of @let@.
33+-- This is essentially let from do-notation.
34+-- However, since we don't support the @Eff@ monad,
35+-- we actually want the normal @let@.
36+--
37+psciLet :: Parsec String P.ParseState Command
38+psciLet = Let <$> (P.Let <$> (P.reserved "let" *> P.indented *> C.mark (many1 (C.same *> P.parseDeclaration))))
39+
40+-- |
41+-- Parses PSCI metacommands or expressions input from the user.
42+--
43+parseCommand :: String -> Either ParseError Command
44+parseCommand = P.runIndentParser "" $ choice
45+ [ P.whiteSpace *> char ':' *> (psciHelp <|> psciImport <|> psciLoadFile <|> psciQuit <|> psciReload <|> psciTypeOf <|> psciKindOf <|> psciBrowse <|> psciShowModules)
46+ , try psciLet
47+ , psciExpression
48+ ] <* eof
49+
50+-- |
51+-- Parses expressions entered at the PSCI repl.
52+--
53+psciExpression :: Parsec String P.ParseState Command
54+psciExpression = Expression <$> P.parseValue
55+
56+-- |
57+-- Parses 'Commands.Help' command.
58+--
59+psciHelp :: Parsec String P.ParseState Command
60+psciHelp = Help <$ char '?'
61+
62+-- |
63+-- Parses 'Commands.Import' command.
64+--
65+psciImport :: Parsec String P.ParseState Command
66+psciImport = Import <$> (char 'i' *> P.whiteSpace *> P.moduleName)
67+
68+-- |
69+-- Parses 'Commands.LoadFile' command.
70+--
71+psciLoadFile :: Parsec String P.ParseState Command
72+psciLoadFile = LoadFile . trimEnd <$> (char 'm' *> P.whiteSpace *> manyTill anyChar eof)
73+
74+-- | Trim end of input string
75+trimEnd :: String -> String
76+trimEnd = reverse . dropWhile isSpace . reverse
77+
78+-- |
79+-- Parses 'Commands.Quit' command.
80+--
81+psciQuit :: Parsec String P.ParseState Command
82+psciQuit = Quit <$ char 'q'
83+
84+-- |
85+-- Parses 'Commands.Reload' command.
86+--
87+psciReload :: Parsec String P.ParseState Command
88+psciReload = Reset <$ char 'r'
89+
90+-- |
91+-- Parses 'Commands.TypeOf' command.
92+--
93+psciTypeOf :: Parsec String P.ParseState Command
94+psciTypeOf = TypeOf <$> (char 't' *> P.whiteSpace *> P.parseValue)
95+
96+
97+-- |
98+-- Parses 'Commands.KindOf' command.
99+--
100+psciKindOf :: Parsec String P.ParseState Command
101+psciKindOf = KindOf <$> (char 'k' *> P.whiteSpace *> P.parseType)
102+
103+-- |
104+-- Parses 'Commands.Browse' command.
105+--
106+psciBrowse :: Parsec String P.ParseState Command
107+psciBrowse = Browse <$> (char 'b' *> P.whiteSpace *> P.moduleName)
108+
109+-- |
110+-- Show Command
111+psciShowModules :: Parsec String P.ParseState Command
112+psciShowModules = Show . trimEnd <$> (char 's' *> P.whiteSpace *> manyTill anyChar eof)
psgo.cabaldeleted−145
@@ -1,145 +0,0 @@
1−cabal-version: 1.12
2−
3−-- This file has been generated from package.yaml by hpack version 0.35.0.
4−--
5−-- see: https://github.com/sol/hpack
6−
7−name: psgo
8−version: 0.1.0.0
9−description: Please see the README on Github at <https://github.com/andyarvanitis/purescript-native#readme>
10−homepage: https://github.com/andyarvanitis/purescript-native#readme
11−bug-reports: https://github.com/andyarvanitis/purescript-native/issues
12−author: Andy Arvanitis
13−maintainer: example@example.com
14−copyright: 2018 Andy Arvanitis
15−license: BSD3
16−license-file: LICENSE
17−build-type: Simple
18−extra-source-files:
19− README.md
20− ChangeLog.md
21− stack.yaml
22− support/ffi-loader.go
23− support/go.mod.ffi-loader
24− support/go.mod.output
25− support/go.mod.working
26−
27−source-repository head
28− type: git
29− location: https://github.com/andyarvanitis/purescript-native
30−
31−library
32− exposed-modules:
33− CodeGen.IL
34− CodeGen.IL.Common
35− CodeGen.IL.Optimizer
36− CodeGen.IL.Optimizer.Common
37− CodeGen.IL.Optimizer.Inliner
38− CodeGen.IL.Optimizer.MagicDo
39− CodeGen.IL.Optimizer.TCO
40− CodeGen.IL.Printer
41− Tests
42− other-modules:
43− Paths_psgo
44− hs-source-dirs:
45− src
46− default-extensions:
47− ConstraintKinds
48− DataKinds
49− DeriveFunctor
50− EmptyDataDecls
51− FlexibleContexts
52− KindSignatures
53− LambdaCase
54− MultiParamTypeClasses
55− NoImplicitPrelude
56− PatternGuards
57− PatternSynonyms
58− RankNTypes
59− RecordWildCards
60− OverloadedStrings
61− ScopedTypeVariables
62− TupleSections
63− ViewPatterns
64− build-depends:
65− aeson >=1.0 && <1.5
66− , base >=4.7 && <5
67− , base-compat >=0.6.0
68− , bytestring >=0.10.8.2 && <0.11
69− , containers
70− , directory
71− , file-embed
72− , filemanip
73− , filepath
74− , gitrev
75− , monad-parallel >=0.7.2.2 && <0.8
76− , mtl >=2.1.0 && <2.3.0
77− , pattern-arrows >=0.0.2 && <0.1
78− , process
79− , protolude >=0.1.6
80− , purescript
81− , safe >=0.3.9 && <0.4
82− , text
83− , transformers >=0.3.0 && <0.6
84− default-language: Haskell2010
85−
86−executable psgo
87− main-is: Main.hs
88− other-modules:
89− Paths_psgo
90− hs-source-dirs:
91− app
92− ghc-options: -threaded -rtsopts -with-rtsopts=-N
93− build-depends:
94− aeson >=1.0 && <1.5
95− , base >=4.7 && <5
96− , base-compat >=0.6.0
97− , bytestring >=0.10.8.2 && <0.11
98− , containers
99− , directory
100− , file-embed
101− , filemanip
102− , filepath
103− , gitrev
104− , monad-parallel >=0.7.2.2 && <0.8
105− , mtl >=2.1.0 && <2.3.0
106− , pattern-arrows >=0.0.2 && <0.1
107− , process
108− , protolude >=0.1.6
109− , psgo
110− , purescript
111− , safe >=0.3.9 && <0.4
112− , text
113− , transformers >=0.3.0 && <0.6
114− default-language: Haskell2010
115−
116−test-suite psgo-test
117− type: exitcode-stdio-1.0
118− main-is: Spec.hs
119− other-modules:
120− Paths_psgo
121− hs-source-dirs:
122− test
123− ghc-options: -threaded -rtsopts -with-rtsopts=-N
124− build-depends:
125− aeson >=1.0 && <1.5
126− , base >=4.7 && <5
127− , base-compat >=0.6.0
128− , bytestring >=0.10.8.2 && <0.11
129− , containers
130− , directory
131− , file-embed
132− , filemanip
133− , filepath
134− , gitrev
135− , monad-parallel >=0.7.2.2 && <0.8
136− , mtl >=2.1.0 && <2.3.0
137− , pattern-arrows >=0.0.2 && <0.1
138− , process
139− , protolude >=0.1.6
140− , psgo
141− , purescript
142− , safe >=0.3.9 && <0.4
143− , text
144− , transformers >=0.3.0 && <0.6
145− default-language: Haskell2010
purescript.cabalnew file+166
@@ -0,0 +1,166 @@
1+name: purescript
2+version: 0.6.0.2
3+cabal-version: >=1.8
4+build-type: Simple
5+license: MIT
6+license-file: LICENSE
7+copyright: (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
8+maintainer: Phil Freeman <paf31@cantab.net>
9+stability: experimental
10+synopsis: PureScript Programming Language Compiler
11+description: A small strongly, statically typed programming language with expressive types, inspired by Haskell and compiling to Javascript.
12+category: Language
13+Homepage: http://www.purescript.org/
14+author: Phil Freeman <paf31@cantab.net>,
15+ Gary Burgess <gary.burgess@gmail.com>,
16+ Hardy Jones <jones3.hardy@gmail.com>
17+
18+extra-source-files: prelude/prelude.purs
19+ , examples/passing/*.purs
20+ , examples/failing/*.purs
21+
22+source-repository head
23+ type: git
24+ location: https://github.com/purescript/purescript.git
25+
26+library
27+ build-depends: base >=4 && <5,
28+ cmdtheline == 0.2.*,
29+ containers -any,
30+ unordered-containers -any,
31+ directory >= 1.2,
32+ filepath -any,
33+ mtl >= 2.1.0 && < 2.3.0,
34+ parsec -any,
35+ transformers >= 0.3 && < 0.5,
36+ utf8-string -any,
37+ pattern-arrows >= 0.0.2 && < 0.1,
38+ monad-unify >= 0.2.2 && < 0.3,
39+ file-embed >= 0.0.7 && < 0.0.8,
40+ time -any
41+ exposed-modules: Language.PureScript
42+ Language.PureScript.AST
43+ Language.PureScript.AST.Binders
44+ Language.PureScript.AST.Declarations
45+ Language.PureScript.AST.Operators
46+ Language.PureScript.AST.SourcePos
47+ Language.PureScript.AST.Traversals
48+ Language.PureScript.CodeGen
49+ Language.PureScript.CodeGen.Common
50+ Language.PureScript.CodeGen.Externs
51+ Language.PureScript.CodeGen.JS
52+ Language.PureScript.CodeGen.JS.AST
53+ Language.PureScript.Constants
54+ Language.PureScript.DeadCodeElimination
55+ Language.PureScript.Environment
56+ Language.PureScript.Errors
57+ Language.PureScript.Kinds
58+ Language.PureScript.ModuleDependencies
59+ Language.PureScript.Names
60+ Language.PureScript.Optimizer
61+ Language.PureScript.Optimizer.Blocks
62+ Language.PureScript.Optimizer.Common
63+ Language.PureScript.Optimizer.Inliner
64+ Language.PureScript.Optimizer.MagicDo
65+ Language.PureScript.Optimizer.TCO
66+ Language.PureScript.Optimizer.Unused
67+ Language.PureScript.Options
68+ Language.PureScript.Parser
69+ Language.PureScript.Parser.Common
70+ Language.PureScript.Parser.Declarations
71+ Language.PureScript.Parser.Kinds
72+ Language.PureScript.Parser.State
73+ Language.PureScript.Parser.Types
74+ Language.PureScript.Pretty
75+ Language.PureScript.Pretty.Common
76+ Language.PureScript.Pretty.JS
77+ Language.PureScript.Pretty.Kinds
78+ Language.PureScript.Pretty.Types
79+ Language.PureScript.Pretty.Values
80+ Language.PureScript.Renamer
81+ Language.PureScript.Sugar
82+ Language.PureScript.Sugar.BindingGroups
83+ Language.PureScript.Sugar.CaseDeclarations
84+ Language.PureScript.Sugar.DoNotation
85+ Language.PureScript.Sugar.Names
86+ Language.PureScript.Sugar.Operators
87+ Language.PureScript.Sugar.TypeClasses
88+ Language.PureScript.Sugar.TypeDeclarations
89+ Language.PureScript.Supply
90+ Language.PureScript.Traversals
91+ Language.PureScript.TypeChecker
92+ Language.PureScript.TypeChecker.Entailment
93+ Language.PureScript.TypeChecker.Kinds
94+ Language.PureScript.TypeChecker.Monad
95+ Language.PureScript.TypeChecker.Rows
96+ Language.PureScript.TypeChecker.Skolems
97+ Language.PureScript.TypeChecker.Subsumption
98+ Language.PureScript.TypeChecker.Synonyms
99+ Language.PureScript.TypeChecker.Types
100+ Language.PureScript.TypeChecker.Unify
101+ Language.PureScript.TypeClassDictionaries
102+ Language.PureScript.Types
103+ exposed: True
104+ buildable: True
105+ hs-source-dirs: src
106+ other-modules: Paths_purescript
107+ ghc-options: -Wall -O2
108+
109+executable psc
110+ build-depends: base >=4 && <5, cmdtheline -any, containers -any,
111+ directory -any, filepath -any, mtl -any, parsec -any,
112+ purescript -any, transformers -any, utf8-string -any
113+ main-is: Main.hs
114+ buildable: True
115+ hs-source-dirs: psc
116+ other-modules:
117+ ghc-options: -Wall -O2 -fno-warn-unused-do-bind
118+
119+executable psc-make
120+ build-depends: base >=4 && <5, cmdtheline -any, containers -any,
121+ directory -any, filepath -any, mtl -any, parsec -any,
122+ purescript -any, transformers -any, utf8-string -any
123+ main-is: Main.hs
124+ buildable: True
125+ hs-source-dirs: psc-make
126+ other-modules:
127+ ghc-options: -Wall -O2 -fno-warn-unused-do-bind
128+
129+executable psci
130+ build-depends: base >=4 && <5, containers -any, directory -any, filepath -any,
131+ mtl -any, parsec -any, haskeline >= 0.7.0.0, purescript -any,
132+ transformers -any, utf8-string -any, process -any,
133+ cmdtheline -any
134+ main-is: Main.hs
135+ buildable: True
136+ hs-source-dirs: psci
137+ other-modules: Commands
138+ Parser
139+ ghc-options: -Wall -O2
140+
141+executable psc-docs
142+ build-depends: base >=4 && <5, cmdtheline -any, purescript -any, utf8-string -any,
143+ process -any, mtl -any
144+ main-is: Main.hs
145+ buildable: True
146+ hs-source-dirs: psc-docs
147+ other-modules:
148+ ghc-options: -Wall -O2
149+
150+executable hierarchy
151+ build-depends: base >=4 && <5, cmdtheline -any, purescript -any, utf8-string -any,
152+ process -any, mtl -any, parsec -any, filepath -any, directory -any
153+ main-is: Main.hs
154+ buildable: True
155+ hs-source-dirs: hierarchy
156+ other-modules:
157+ ghc-options: -Wall -O2
158+
159+test-suite tests
160+ build-depends: base >=4 && <5, containers -any, directory -any,
161+ filepath -any, mtl -any, parsec -any, purescript -any,
162+ transformers -any, utf8-string -any, process -any
163+ type: exitcode-stdio-1.0
164+ main-is: Main.hs
165+ buildable: True
166+ hs-source-dirs: tests
src/CodeGen/IL.hsdeleted−321
@@ -1,321 +0,0 @@
1−-- | This module generates code in the core imperative representation from
2−-- elaborated PureScript code.
3−module CodeGen.IL
4− ( module AST
5− , module Common
6− , moduleToIL
7− ) where
8−
9−import Prelude.Compat
10−import Protolude (ordNub)
11−
12−import Control.Arrow ((&&&))
13−import Control.Monad (forM, liftM, replicateM, void)
14−import Control.Monad.Supply.Class
15−
16−import Data.List ((\\), delete, intersect, nub)
17−import qualified Data.Foldable as F
18−import qualified Data.Map as M
19−import Data.Maybe (fromMaybe, isNothing, mapMaybe)
20−import Data.Monoid ((<>))
21−import Data.String (fromString)
22−import Data.Text (Text)
23−import qualified Data.Text as T
24−
25−import Language.PureScript.AST.SourcePos
26−import Language.PureScript.CoreImp.AST (AST)
27−import qualified Language.PureScript.CoreImp.AST as AST
28−import Language.PureScript.CoreFn
29−import Language.PureScript.Crash
30−import Language.PureScript.Names
31−import Language.PureScript.Options
32−import Language.PureScript.PSString (PSString, mkString)
33−import Language.PureScript.Traversals (sndM)
34−import qualified Language.PureScript.Constants as C
35−
36−import System.FilePath.Posix ((</>))
37−
38−import CodeGen.IL.Common as Common
39−import CodeGen.IL.Optimizer
40−import CodeGen.IL.Printer
41−
42−data DeclType = ModuleDecl | LetDecl | RecLetDecl deriving (Eq)
43−
44−-- | Generate code in the simplified intermediate representation for all declarations in a
45−-- module.
46−moduleToIL
47− :: forall m
48− -- . (Monad m, MonadReader Options m, MonadSupply m, MonadError MultipleErrors m)
49− . (Monad m, MonadSupply m)
50− => Module Ann
51− -> Text
52− -> m (Text, [Text], [AST], Text, Text)
53−moduleToIL (Module _ coms mn _ imps _ foreigns decls) project =
54− do
55− ilDecls <- mapM (bindToIL ModuleDecl) decls
56− optimized <- traverse (traverse (optimize modName')) ilDecls
57− let optimized' = concat optimized
58− values = annotValue <$> optimized'
59− foreigns' = moduleIdentToIL <$> foreigns
60− interface = interfaceSource modName values foreigns
61− imports = nub . concat $ importToIL <$> optimized'
62− implHeader = implHeaderSource modName imports project
63− implFooter = implFooterSource (runModuleName mn) foreigns
64− return $ (interface, foreigns', optimized', implHeader, implFooter)
65− where
66− modName = moduleNameToIL mn
67− modName' = AST.Var Nothing modName
68−
69− annotValue :: AST -> (Text, Bool)
70− annotValue (AST.Function _ (Just name) [] (AST.Block _ [AST.Return _ ret]))
71− | isLiteral ret = (name, True)
72− annotValue (AST.Function _ (Just name) [] _) = (name, False)
73− annotValue _ = error "Unexpected top-level value form"
74−
75− -- | Extracts all declaration names from a binding group.
76− getNames :: Bind Ann -> [Ident]
77− getNames (NonRec _ ident _) = [ident]
78− getNames (Rec vals) = map (snd . fst) vals
79−
80− -- | Generates IL code for a module import
81− --
82− importToIL :: AST -> [Text]
83− importToIL = AST.everything (++) modRef
84− where
85− modRef (AST.Indexer _ (AST.Var _ _) (AST.Var _ mname))
86− | not $ T.null mname = [extract mname]
87− modRef _ = []
88− extract :: Text -> Text
89− extract = T.replace "_" "." . T.dropWhileEnd (=='_')
90−
91− -- |
92− -- Generate code in the simplified intermediate representation for a declaration
93− --
94− bindToIL :: DeclType -> Bind Ann -> m [AST]
95− bindToIL dt (NonRec ann ident val) = return <$> nonRecToIL dt ann ident val
96− bindToIL dt (Rec vals) = forM vals (uncurry . uncurry $ nonRecToIL dt')
97− where
98− dt' = if dt == LetDecl then RecLetDecl else dt
99−
100− -- | Generate code in the simplified intermediate representation for a single non-recursive
101− -- declaration.
102− --
103− -- The main purpose of this function is to handle code generation for comments.
104− nonRecToIL :: DeclType -> Ann -> Ident -> Expr Ann -> m AST
105− nonRecToIL dt a i e@(extractAnn -> (_, com, _, _)) | not (null com) = do
106− -- withoutComment <- asks optionsNoComments
107− let withoutComment = False
108− if withoutComment
109− then nonRecToIL dt a i (modifyAnn removeComments e)
110− else AST.Comment Nothing com <$> nonRecToIL dt a i (modifyAnn removeComments e)
111− nonRecToIL ModuleDecl (ss, _, _, _) ident val = do
112− il <- valueToIL val
113− pure $ AST.Function Nothing (Just $ moduleIdentToIL ident) [] (AST.Block Nothing [AST.Return Nothing il])
114− nonRecToIL RecLetDecl (ss, _, _, _) ident val = do
115− ilExpr <- valueToIL val
116− pure $ AST.Assignment Nothing (AST.Var Nothing $ identToIL ident) ilExpr
117− nonRecToIL _ (ss, _, _, _) ident val = do
118− il <- valueToIL val
119− pure $ AST.VariableIntroduction Nothing (identToIL ident) (Just il)
120−
121− -- | Generate code in the simplified intermediate representation for a variable based on a
122− -- PureScript identifier.
123− var :: Ident -> AST
124− var = AST.Var Nothing . identToIL
125−
126− accessorString :: PSString -> AST -> AST
127− accessorString prop = AST.Indexer Nothing (AST.StringLiteral Nothing prop)
128−
129− -- | Generate code in the simplified intermediate representation for a value or expression.
130−
131− valueToIL :: Expr Ann -> m AST
132− valueToIL (Literal (pos, _, _, _) l) = literalToValueIL pos l
133− valueToIL (Accessor _ prop val) =
134− accessorString prop <$> valueToIL val
135− valueToIL (ObjectUpdate _ o ps) = do
136− obj <- valueToIL o
137− updates <- mapM (sndM valueToIL) ps
138− obj' <- freshName'
139− let objVar = AST.Var Nothing obj'
140− copy = AST.VariableIntroduction Nothing obj' (Just $ copyDict obj)
141− assign (k, v) = AST.Assignment Nothing (accessorString k objVar) v
142− sts = copy : (assign <$> updates) ++ [AST.Return Nothing objVar]
143− return $ AST.App Nothing (AST.Function Nothing Nothing [] (AST.Block Nothing sts)) []
144− valueToIL (Abs _ arg val) = do
145− ret <- valueToIL val
146− let ilArg = case arg of
147− UnusedIdent -> []
148− _ -> [identToIL arg]
149− return $ AST.Function Nothing Nothing ilArg (AST.Block Nothing [AST.Return Nothing ret])
150− valueToIL e@App{} = do
151− let (f, args) = unApp e []
152− args' <- mapM valueToIL args
153− fn <- valueToIL f
154− case f of
155− Var (_, _, _, Just IsNewtype) _ -> return (head args')
156− _ -> flip (foldl (\fn a -> AST.App Nothing fn [a])) args' <$> valueToIL f
157− where
158− unApp :: Expr Ann -> [Expr Ann] -> (Expr Ann, [Expr Ann])
159− unApp (App _ val arg) args = unApp val (arg : args)
160− unApp other args = (other, args)
161− valueToIL (Var _ ident) = return $ varToIL ident
162− valueToIL (Case (ss, _, _, _) values binders) = do
163− vals <- mapM valueToIL values
164− bindersToIL ss binders vals
165− valueToIL (Let _ ds val) = do
166− let recurs = concatMap getNames $ filter isRec ds
167− recurDs = (\v -> AST.VariableIntroduction Nothing (identToIL v) Nothing) <$> recurs
168− ds' <- concat <$> mapM (bindToIL LetDecl) ds
169− ret <- valueToIL val
170− return $ AST.App Nothing (AST.Function Nothing Nothing [] (AST.Block Nothing (recurDs ++ ds' ++ [AST.Return Nothing ret]))) []
171− where
172− isRec :: Bind Ann -> Bool
173− isRec (Rec _) = True
174− isRec _ = False
175− valueToIL (Constructor (_, _, _, Just IsNewtype) _ (ProperName ctor) _) = error "IsNewtype"
176− valueToIL (Constructor _ _ (ProperName ctor) fields) =
177− let body = AST.ObjectLiteral Nothing $ (mkString ctor, AST.BooleanLiteral Nothing True) :
178− ((\field -> (mkString (identToIL field), var field)) `map` fields)
179− fn = foldr (\f inner -> AST.Function Nothing Nothing [identToIL f] (AST.Block Nothing [AST.Return Nothing inner])) body fields
180− in return fn
181−
182−
183− iife :: Text -> [AST] -> AST
184− iife v exprs = AST.App Nothing (AST.Function Nothing Nothing [] (AST.Block Nothing $ exprs ++ [AST.Return Nothing $ AST.Var Nothing v])) []
185−
186− literalToValueIL :: SourceSpan -> Literal (Expr Ann) -> m AST
187− literalToValueIL ss (NumericLiteral (Left i)) = return $ AST.NumericLiteral (Just ss) (Left i)
188− literalToValueIL ss (NumericLiteral (Right n)) = return $ AST.NumericLiteral (Just ss) (Right n)
189− literalToValueIL ss (StringLiteral s) = return $ AST.StringLiteral (Just ss) s
190− literalToValueIL ss (CharLiteral c) = return $ AST.StringLiteral (Just ss) (fromString [c])
191− literalToValueIL ss (BooleanLiteral b) = return $ AST.BooleanLiteral (Just ss) b
192− literalToValueIL ss (ArrayLiteral xs) = AST.ArrayLiteral (Just ss) <$> mapM valueToIL xs
193− literalToValueIL ss (ObjectLiteral ps) = AST.ObjectLiteral (Just ss) <$> mapM (sndM valueToIL) ps
194−
195− -- | Generate code in the simplified intermediate representation for a reference to a
196− -- variable.
197− varToIL :: Qualified Ident -> AST
198− varToIL (Qualified Nothing ident) = var ident
199− varToIL qual = qualifiedToIL id qual
200−
201− -- | Generate code in the simplified intermediate representation for a reference to a
202− -- variable that may have a qualified name.
203− qualifiedToIL :: (a -> Ident) -> Qualified a -> AST
204− qualifiedToIL f (Qualified (Just (ModuleName mn')) a) | mn' == C.prim = AST.Var Nothing . moduleIdentToIL $ f a
205− qualifiedToIL f (Qualified (Just mn') a) | mn /= mn' = AST.Indexer Nothing (AST.Var Nothing . moduleIdentToIL $ f a) (AST.Var Nothing (moduleNameToIL mn'))
206− qualifiedToIL f (Qualified _ a) = AST.Indexer Nothing (AST.Var Nothing . moduleIdentToIL $ f a) (AST.Var Nothing "")
207−
208− -- foreignIdent :: Ident -> AST
209− -- foreignIdent ident = accessorString (mkString $ runIdent ident) (AST.Var Nothing "$foreign")
210−
211− -- | Generate code in the simplified intermediate representation for pattern match binders
212− -- and guards.
213− bindersToIL :: SourceSpan -> [CaseAlternative Ann] -> [AST] -> m AST
214− bindersToIL ss binders vals = do
215− valNames <- replicateM (length vals) freshName'
216− let assignments = zipWith (AST.VariableIntroduction Nothing) valNames (map Just vals)
217− ils <- forM binders $ \(CaseAlternative bs result) -> do
218− ret <- guardsToIL result
219− go valNames ret bs
220− return $ AST.App Nothing (AST.Function Nothing Nothing [] (AST.Block Nothing (assignments ++ concat ils ++ [AST.Throw Nothing (AST.StringLiteral Nothing $ mkString failedPatternMessage)])))
221− []
222− where
223− go :: [Text] -> [AST] -> [Binder Ann] -> m [AST]
224− go _ done [] = return done
225− go (v:vs) done' (b:bs) = do
226− done'' <- go vs done' bs
227− binderToIL v done'' b
228− go _ _ _ = internalError "Invalid arguments to bindersToIL"
229−
230− failedPatternMessage :: Text
231− failedPatternMessage = "Failed pattern match at " <> runModuleName mn <> " " <> displayStartEndPos ss
232−
233− guardsToIL :: Either [(Guard Ann, Expr Ann)] (Expr Ann) -> m [AST]
234− guardsToIL (Left gs) = traverse genGuard gs where
235− genGuard (cond, val) = do
236− cond' <- valueToIL cond
237− val' <- valueToIL val
238− return
239− (AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo cond' (AST.BooleanLiteral Nothing True))
240− (AST.Block Nothing [AST.Return Nothing val']) Nothing)
241−
242− guardsToIL (Right v) = return . AST.Return Nothing <$> valueToIL v
243−
244− -- | Generate code in the simplified intermediate representation for a pattern match
245− -- binder.
246− binderToIL :: Text -> [AST] -> Binder Ann -> m [AST]
247− binderToIL _ done NullBinder{} = return done
248− binderToIL varName done (LiteralBinder _ l) =
249− literalToBinderIL varName done l
250− binderToIL varName done (VarBinder _ ident) =
251− return (AST.VariableIntroduction Nothing (identToIL ident) (Just (AST.Var Nothing varName)) : done)
252− binderToIL varName done (ConstructorBinder (_, _, _, Just IsNewtype) _ _ [b]) =
253− binderToIL varName done b
254− binderToIL varName done (ConstructorBinder (_, _, _, Just (IsConstructor ctorType fields)) _ (Qualified _ (ProperName ctor)) bs) = do
255− il <- go (zip fields bs) done
256− return $ case ctorType of
257− ProductType -> il
258− SumType ->
259− [AST.IfElse Nothing (AST.InstanceOf Nothing (AST.Var Nothing varName) (AST.StringLiteral Nothing (mkString ctor)))
260− (AST.Block Nothing il)
261− Nothing]
262− where
263− go :: [(Ident, Binder Ann)] -> [AST] -> m [AST]
264− go [] done' = return done'
265− go ((field, binder) : remain) done' = do
266− argVar <- freshName'
267− done'' <- go remain done'
268− il <- binderToIL argVar done'' binder
269− return (AST.VariableIntroduction Nothing argVar (Just $ accessorString (mkString $ identToIL field) $ AST.Var Nothing varName) : il)
270−
271− binderToIL _ _ ConstructorBinder{} =
272− internalError "binderToIL: Invalid ConstructorBinder in binderToIL"
273− binderToIL varName done (NamedBinder _ ident binder) = do
274− il <- binderToIL varName done binder
275− return (AST.VariableIntroduction Nothing (identToIL ident) (Just (AST.Var Nothing varName)) : il)
276−
277− literalToBinderIL :: Text -> [AST] -> Literal (Binder Ann) -> m [AST]
278− literalToBinderIL varName done (NumericLiteral num) =
279− return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo (AST.Var Nothing varName) (AST.NumericLiteral Nothing num)) (AST.Block Nothing done) Nothing]
280− literalToBinderIL varName done (CharLiteral c) =
281− return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo (AST.Var Nothing varName) (AST.StringLiteral Nothing (fromString [c]))) (AST.Block Nothing done) Nothing]
282− literalToBinderIL varName done (StringLiteral str) =
283− return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo (AST.Var Nothing varName) (AST.StringLiteral Nothing str)) (AST.Block Nothing done) Nothing]
284− literalToBinderIL varName done (BooleanLiteral True) =
285− return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo (AST.Var Nothing varName) (AST.BooleanLiteral Nothing True)) (AST.Block Nothing done) Nothing]
286− literalToBinderIL varName done (BooleanLiteral False) =
287− return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo (AST.Var Nothing varName) (AST.BooleanLiteral Nothing False)) (AST.Block Nothing done) Nothing]
288− -- return [AST.IfElse Nothing (AST.Unary Nothing AST.Not (AST.Var Nothing varName)) (AST.Block Nothing done) Nothing]
289− literalToBinderIL varName done (ObjectLiteral bs) = go done bs
290− where
291− go :: [AST] -> [(PSString, Binder Ann)] -> m [AST]
292− go done' [] = return done'
293− go done' ((prop, binder):bs') = do
294− propVar <- freshName'
295− done'' <- go done' bs'
296− il <- binderToIL propVar done'' binder
297− return (AST.VariableIntroduction Nothing propVar (Just (accessorString prop (AST.Var Nothing varName))) : il)
298− literalToBinderIL varName done (ArrayLiteral bs) = do
299− il <- go done 0 bs
300− return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo
301− (arrayLength $ AST.Var Nothing varName)
302− (AST.NumericLiteral Nothing (Left (fromIntegral $ length bs))))
303− (AST.Block Nothing il) Nothing]
304− where
305− go :: [AST] -> Integer -> [Binder Ann] -> m [AST]
306− go done' _ [] = return done'
307− go done' index (binder:bs') = do
308− elVar <- freshName'
309− done'' <- go done' (index + 1) bs'
310− il <- binderToIL elVar done'' binder
311− return (AST.VariableIntroduction Nothing elVar (Just (AST.Indexer Nothing (AST.NumericLiteral Nothing (Left index)) (AST.Var Nothing varName))) : il)
312−
313−emptyAnn :: Ann
314−emptyAnn = (SourceSpan "" (SourcePos 0 0) (SourcePos 0 0), [], Nothing, Nothing)
315−
316−arrayLength :: AST -> AST
317−arrayLength a = AST.App Nothing (AST.Var Nothing arrayLengthFn) [a]
318−-- arrayLength a = AST.Var Nothing (arrayLengthFn <> "(" <> prettyPrintIL1 a <> ")")
319−
320−copyDict :: AST -> AST
321−copyDict a = AST.App Nothing (AST.Var Nothing copyDictFn) [a]
src/CodeGen/IL/Common.hsdeleted−196
@@ -1,196 +0,0 @@
1−-- | Common code generation utility functions
2−module CodeGen.IL.Common where
3−
4−import Prelude.Compat
5−
6−import Control.Monad.Supply.Class (MonadSupply, freshName)
7−import Data.Char
8−import Data.Maybe (maybe)
9−import Data.Monoid ((<>))
10−import Data.Text (Text)
11−import qualified Data.Text as T
12−
13−import Language.PureScript.Crash
14−import Language.PureScript.Names
15−
16−import qualified Language.PureScript.Constants as C
17−
18−moduleNameToIL :: ModuleName -> Text
19−moduleNameToIL (ModuleName mn) =
20− let name = T.replace "." "_" mn
21− in if nameIsILBuiltIn name then (name <> moduleRenamerMarker) else name
22−
23−moduleNameToIL' :: ModuleName -> Text
24−moduleNameToIL' (ModuleName mn) = T.replace "_" "." mn
25−
26−-- | Convert an 'Ident' into a valid IL identifier:
27−--
28−-- * Alphanumeric characters are kept unmodified.
29−--
30−-- * Reserved IL identifiers are wrapped with '_'.
31−--
32−identToIL :: Ident -> Text
33−identToIL UnusedIdent = unusedName
34−identToIL (Ident "$__unused") = unusedName
35−identToIL (Ident name) | name == C.undefined = undefinedName -- Note: done in Printer.hs too
36−identToIL (Ident name) = properToIL name
37−identToIL (GenIdent _ _) = internalError "GenIdent in identToIL"
38−
39−moduleIdentToIL :: Ident -> Text
40−moduleIdentToIL UnusedIdent = unusedName
41−moduleIdentToIL (Ident name) | name == C.undefined = undefinedName
42−moduleIdentToIL (Ident name) = moduleProperToIL name
43−moduleIdentToIL (GenIdent _ _) = internalError "GenIdent in identToIL"
44−
45−undefinedName :: Text
46−undefinedName = "Undefined"
47−
48−unusedName :: Text
49−unusedName = "_"
50−
51−properToIL :: Text -> Text
52−properToIL name
53− | nameIsILReserved name = "ˉ" <> name
54− | otherwise = T.concatMap identCharToText name
55−
56−-- | Attempts to find a human-readable name for a symbol, if none has been specified returns the
57−-- ordinal value.
58−identCharToText :: Char -> Text
59−identCharToText 'ṩ' = "_ṩ"
60−identCharToText c | isAlphaNum c = T.singleton c
61−identCharToText '_' = "_"
62−identCharToText '\'' = "ꞌ" -- lowercase saltillo
63−identCharToText c = error (show (ord c)) -- TODO: should never occur now(?)
64−
65−moduleProperToIL :: Text -> Text
66−moduleProperToIL = T.concatMap identCharToText
67−
68−-- | Checks whether an identifier name is reserved in IL.
69−nameIsILReserved :: Text -> Bool
70−nameIsILReserved name =
71− name `elem` ilAnyReserved
72−
73−-- | Checks whether a name matches a built-in value in IL.
74−nameIsILBuiltIn :: Text -> Bool
75−nameIsILBuiltIn name =
76− name `elem`
77− [ "Any"
78− , "Apply"
79− , "Contains"
80− , "CopyDict"
81− , "Dict"
82− , "EffFn"
83− , "Fn"
84− , "Foreign"
85− , "Get"
86− , "Index"
87− , "Is"
88− , "Length"
89− , "Once"
90− , "Run"
91− , "Undefined"
92− ]
93−
94−ilAnyReserved :: [Text]
95−ilAnyReserved =
96− concat
97− [ ilKeywords
98− , ilLiterals
99− ]
100−
101−ilKeywords :: [Text]
102−ilKeywords =
103− [ "break"
104− , "case"
105− , "chan"
106− , "const"
107− , "continue"
108− , "default"
109− , "defer"
110− , "else"
111− , "fallthrough"
112− , "for"
113− , "func"
114− , "go"
115− , "goto"
116− , "if"
117− , "import"
118− , "interface"
119− , "map"
120− , "package"
121− , "range"
122− , "return"
123− , "select"
124− , "struct"
125− , "switch"
126− , "type"
127− , "var"
128− ]
129−
130−ilLiterals :: [Text]
131−ilLiterals =
132− [ "init"
133− , "nil"
134− , "int"
135− , "int8"
136− , "int16"
137− , "int32"
138− , "int64"
139− , "uint"
140− , "uint8"
141− , "uint16"
142− , "uint32"
143− , "uint64"
144− , "uintptr"
145− , "float32"
146− , "float64"
147− , "complex64"
148− , "complex128"
149− , "byte"
150− , "rune"
151− , "string"
152− ]
153−
154−withPrefix :: Text -> Text
155−withPrefix s = "Ꞌ" <> s -- uppercase saltillo
156−
157−anyType :: Text
158−anyType = "Any"
159−
160−dictType :: Text
161−dictType = "Dict"
162−
163−arrayType :: Text
164−arrayType = "[]" <> anyType
165−
166−uncurriedFnType :: Int -> Text
167−uncurriedFnType i = "Fn" <> (T.pack . show $ i)
168−
169−int :: Text
170−int = "int"
171−
172−float :: Text
173−float = "float64"
174−
175−bool :: Text
176−bool = "bool"
177−
178−string :: Text
179−string = "string"
180−
181−arrayLengthFn :: Text
182−arrayLengthFn = "Length"
183−
184−indexFn :: Text
185−indexFn = "Index"
186−
187−copyDictFn :: Text
188−copyDictFn = "CopyDict"
189−
190−freshName' :: MonadSupply m => m Text
191−freshName' = do
192− name <- freshName
193− return $ T.replace "$" "ṩ" name
194−
195−moduleRenamerMarker :: Text
196−moduleRenamerMarker = "__"
src/CodeGen/IL/Optimizer.hsdeleted−81
@@ -1,81 +0,0 @@
1−-- | This module optimizes code in the intermediate representation.
2−module CodeGen.IL.Optimizer (optimize) where
3−
4−import Prelude.Compat
5−
6−import Control.Monad.Supply.Class (MonadSupply)
7−import Data.Text (Text)
8−import Language.PureScript.CoreImp.AST
9−import Language.PureScript.CoreImp.Optimizer.Blocks
10−import Language.PureScript.CoreImp.Optimizer.Common hiding (isDict)
11−import Language.PureScript.CoreImp.Optimizer.Inliner (etaConvert, evaluateIifes, inlineVariables, unThunk)
12−import Language.PureScript.CoreImp.Optimizer.Unused
13−
14−import CodeGen.IL.Common (unusedName)
15−import CodeGen.IL.Optimizer.Inliner
16−import CodeGen.IL.Optimizer.MagicDo
17−import CodeGen.IL.Optimizer.TCO
18−
19−import qualified Language.PureScript.Constants as C
20−
21−-- | Apply a series of optimizer passes to simplified IL code
22−optimize :: MonadSupply m => AST -> AST -> m AST
23−optimize mn il = do
24− il' <- untilFixedPoint (inlineFnComposition . inlineUnsafeCoerce . inlineUnsafePartial . tidyUp) il
25− il'' <- untilFixedPoint (return . ignoreUnusedResults . inlineCommonValues . inlineCommonOperators . tidyUp) . tco mn . inlineST
26− =<< untilFixedPoint (return . magicDoST)
27− =<< untilFixedPoint (return . magicDoEff)
28− =<< untilFixedPoint (return . magicDoEffect) il'
29− untilFixedPoint (return . collapseVarDeclarations) il''
30− where
31− tidyUp :: AST -> AST
32− tidyUp = applyAll
33− [ collapseNestedBlocks
34− , collapseNestedIfs
35− , collapseIfChecks
36− , removeCodeAfterReturnStatements
37− , unThunk
38− , etaConvert
39− , evaluateIifes
40− , inlineVariables
41− ]
42−
43−untilFixedPoint :: (Monad m, Eq a) => (a -> m a) -> a -> m a
44−untilFixedPoint f = go
45− where
46− go a = do
47− a' <- f a
48− if a' == a then return a' else go a'
49−
50−collapseIfChecks :: AST -> AST
51−collapseIfChecks = everywhere collapse where
52− collapse :: AST -> AST
53− collapse (IfElse _ (Binary _ EqualTo (BooleanLiteral _ True) (BooleanLiteral _ True)) (Block _ [exprs]) _) = exprs
54− collapse (IfElse _ (Binary _ EqualTo (Indexer _ (Var _ prop) (Var _ val)) (BooleanLiteral _ True)) (Block _ [exprs]) _)
55− | prop == "otherwise" && val == "Data_Boolean" = exprs
56− collapse exprs = exprs
57−
58−collapseVarDeclarations :: AST -> AST
59−collapseVarDeclarations = everywhere collapse where
60− collapse :: AST -> AST
61− collapse (Block ss sts) = Block ss (go Nothing sts)
62− collapse s = s
63−
64− go :: Maybe Text -> [AST] -> [AST]
65− go _ [] = []
66− go Nothing (decl@(VariableIntroduction _ var (Just _)) : sts) = decl : go (Just var) (go Nothing sts)
67− go (Just var') ((VariableIntroduction ss var (Just val)) : sts)
68− | var == var' = (Assignment ss (Var Nothing var) val) : go (Just var') sts
69− go var' (s:sts) = s : go var' sts
70−
71−ignoreUnusedResults :: AST -> AST
72−ignoreUnusedResults = everywhere $ removeFromBlock go
73− where
74− go :: [AST] -> [AST]
75− go [] = []
76− go (VariableIntroduction ss var (Just s) : sts)
77− | not $ any (everything (||) (isUsed var)) sts = sts'
78− where
79− sts' | App{} <- s = s : (go sts)
80− | otherwise = go sts
81− go (s:sts) = s : go sts
src/CodeGen/IL/Optimizer/Common.hsdeleted−18
@@ -1,18 +0,0 @@
1−-- | Common functions used by the various optimizer phases
2−module CodeGen.IL.Optimizer.Common where
3−
4−import Prelude.Compat
5−
6−import Data.Text (Text)
7−
8−import Language.PureScript.CoreImp.AST
9−import Language.PureScript.PSString (PSString, decodeString)
10−
11−isDict :: (Text, PSString) -> AST -> Bool
12−isDict (moduleName, dictName) (Indexer _ (Var _ x) (Var _ y)) =
13− Just x == decodeString dictName && y == moduleName
14−isDict _ _ = False
15−
16−isDict' :: [(Text, PSString)] -> AST -> Bool
17−isDict' xs il = any (`isDict` il) xs
18−
src/CodeGen/IL/Optimizer/Inliner.hsdeleted−435
@@ -1,435 +0,0 @@
1−-- | This module performs basic inlining of known functions
2−module CodeGen.IL.Optimizer.Inliner
3− ( inlineCommonValues
4− , inlineCommonOperators
5− , inlineFnComposition
6− , inlineUnsafeCoerce
7− , inlineUnsafePartial
8− ) where
9−
10−import Prelude.Compat
11−
12−import Control.Monad.Supply.Class (MonadSupply)
13−
14−import Data.Either (rights)
15−import Data.Maybe (fromMaybe)
16−import Data.String (IsString, fromString)
17−import Data.Text (Text)
18−import qualified Data.Text as T
19−
20−import Language.PureScript.PSString (PSString, decodeString, mkString)
21−import Language.PureScript.CoreImp.AST
22−import Language.PureScript.CoreImp.Optimizer.Common hiding (isDict, isDict')
23−import Language.PureScript.AST (SourceSpan(..))
24−import qualified Language.PureScript.Constants as C
25−
26−import CodeGen.IL.Common
27−import CodeGen.IL.Optimizer.Common
28−
29−-- TODO: Potential bug:
30−-- Shouldn't just inline this case: { var x = 0; x.toFixed(10); }
31−-- Needs to be: { 0..toFixed(10); }
32−-- Probably needs to be fixed in pretty-printer instead.
33−shouldInline :: AST -> Bool
34−shouldInline (Var _ _) = True
35−shouldInline (NumericLiteral _ _) = True
36−shouldInline (StringLiteral _ _) = True
37−shouldInline (BooleanLiteral _ _) = True
38−shouldInline (Indexer _ index val) = shouldInline index && shouldInline val
39−shouldInline _ = False
40−
41−inlineCommonValues :: AST -> AST
42−inlineCommonValues = everywhere convert
43− where
44− convert :: AST -> AST
45− convert (App ss fn [dict])
46− | isDict' [semiringNumber, semiringInt] dict && isDict fnZero fn = NumericLiteral ss (Left 0)
47− | isDict' [semiringNumber, semiringInt] dict && isDict fnOne fn = NumericLiteral ss (Left 1)
48− | isDict boundedBoolean dict && isDict fnBottom fn = BooleanLiteral ss False
49− | isDict boundedBoolean dict && isDict fnTop fn = BooleanLiteral ss True
50− convert (App ss (App _ fn [dict]) [x])
51− | isDict ringInt dict && isDict fnNegate fn = Unary ss Negate (unbox x $ snd ringInt)
52− convert (App ss (App _ (App _ fn [dict]) [x]) [y])
53− | isDict semiringInt dict && isDict fnAdd fn = intOp ss Add semiringInt x y
54− | isDict semiringInt dict && isDict fnMultiply fn = intOp ss Multiply semiringInt x y
55− | isDict ringInt dict && isDict fnSubtract fn = intOp ss Subtract ringInt x y
56− convert other = other
57− fnZero = (C.dataSemiring, C.zero)
58− fnOne = (C.dataSemiring, C.one)
59− fnBottom = (C.dataBounded, C.bottom)
60− fnTop = (C.dataBounded, C.top)
61− fnAdd = (C.dataSemiring, C.add)
62− fnMultiply = (C.dataSemiring, C.mul)
63− fnSubtract = (C.dataRing, C.sub)
64− fnNegate = (C.dataRing, C.negate)
65− intOp ss op (_, d) x y = Binary ss op (unbox x d) (unbox y d)
66−
67−inlineCommonOperators :: AST -> AST
68−inlineCommonOperators = everywhereTopDown $ applyAll $
69− [ binary semiringNumber opAdd Add
70− , binary semiringNumber opMul Multiply
71−
72− , binary ringNumber opSub Subtract
73− , unary ringNumber opNegate Negate
74−
75− , binary euclideanRingNumber opDiv Divide
76−
77− -- , binary eqNumber opEq EqualTo
78− -- , binary eqNumber opNotEq NotEqualTo
79− , binary eqInt opEq EqualTo
80− , binary eqInt opNotEq NotEqualTo
81− , binary eqString opEq EqualTo
82− , binary eqString opNotEq NotEqualTo
83− , binary eqChar opEq EqualTo
84− , binary eqChar opNotEq NotEqualTo
85− , binary eqBoolean opEq EqualTo
86− , binary eqBoolean opNotEq NotEqualTo
87−
88− , binary ordBoolean opLessThan LessThan
89− , binary ordBoolean opLessThanOrEq LessThanOrEqualTo
90− , binary ordBoolean opGreaterThan GreaterThan
91− , binary ordBoolean opGreaterThanOrEq GreaterThanOrEqualTo
92− , binary ordChar opLessThan LessThan
93− , binary ordChar opLessThanOrEq LessThanOrEqualTo
94− , binary ordChar opGreaterThan GreaterThan
95− , binary ordChar opGreaterThanOrEq GreaterThanOrEqualTo
96− , binary ordInt opLessThan LessThan
97− , binary ordInt opLessThanOrEq LessThanOrEqualTo
98− , binary ordInt opGreaterThan GreaterThan
99− , binary ordInt opGreaterThanOrEq GreaterThanOrEqualTo
100− , binary ordNumber opLessThan LessThan
101− , binary ordNumber opLessThanOrEq LessThanOrEqualTo
102− , binary ordNumber opGreaterThan GreaterThan
103− , binary ordNumber opGreaterThanOrEq GreaterThanOrEqualTo
104− , binary ordString opLessThan LessThan
105− , binary ordString opLessThanOrEq LessThanOrEqualTo
106− , binary ordString opGreaterThan GreaterThan
107− , binary ordString opGreaterThanOrEq GreaterThanOrEqualTo
108−
109− , binary semigroupString opAppend Add
110−
111− , binary heytingAlgebraBoolean opConj And
112− , binary heytingAlgebraBoolean opDisj Or
113− , unary heytingAlgebraBoolean opNot Not
114−
115− , binary' C.dataIntBits C.or BitwiseOr
116− , binary' C.dataIntBits C.and BitwiseAnd
117− , binary' C.dataIntBits C.xor BitwiseXor
118− , binary' C.dataIntBits C.shl ShiftLeft
119− , binary' C.dataIntBits C.shr ShiftRight
120− , unary' C.dataIntBits C.complement BitwiseNot
121−
122− , inlineNonClassFunction (isModFn (C.dataFunction, C.apply)) $ \f x -> App Nothing f [x]
123− , inlineNonClassFunction (isModFn (C.dataFunction, C.applyFlipped)) $ \x f -> App Nothing f [x]
124− , inlineUnsafeIndex (isModFnWithDict (C.dataArray, C.unsafeIndex)) $ flip (Indexer Nothing)
125− ] ++
126− [ fn | i <- [0..10], fn <- [ mkFn i, runFn i ] ] ++
127− [ fn | i <- [0..10], fn <- [ mkEffFn C.controlMonadEffUncurried C.mkEffFn i, runEffFn C.controlMonadEffUncurried C.runEffFn i ] ] ++
128− [ fn | i <- [0..10], fn <- [ mkEffFn C.effectUncurried C.mkEffectFn i, runEffFn C.effectUncurried C.runEffectFn i ] ]
129− where
130− binary :: (Text, PSString) -> (Text, PSString) -> BinaryOperator -> AST -> AST
131− binary dict@(_, d) fns op = convert where
132− convert :: AST -> AST
133− convert (App ss (App _ (App _ fn [dict']) [x]) [y])
134− | isDict dict dict' && isDict fns fn = Binary ss op (unbox x d) (unbox y d)
135− convert other = other
136− binary' :: Text -> PSString -> BinaryOperator -> AST -> AST
137− binary' moduleName opString op = convert where
138− convert :: AST -> AST
139− convert (App ss (App _ fn [x]) [y]) | isDict (moduleName, opString) fn = Binary ss op (unbox x mn) (unbox y mn)
140− convert other = other
141− mn :: PSString
142− mn = mkString moduleName
143− unary :: (Text, PSString) -> (Text, PSString) -> UnaryOperator -> AST -> AST
144− unary dicts@(_, d) fns op = convert where
145− convert :: AST -> AST
146− convert (App ss (App _ fn [dict']) [x]) | isDict dicts dict' && isDict fns fn = Unary ss op (unbox x d)
147− convert other = other
148− unary' :: Text -> PSString -> UnaryOperator -> AST -> AST
149− unary' moduleName fnName op = convert where
150− convert :: AST -> AST
151− convert (App ss fn [x]) | isDict (moduleName, fnName) fn = Unary ss op (unbox x fnName)
152− convert other = other
153−
154− mkFn :: Int -> AST -> AST
155− mkFn = mkFn' C.dataFunctionUncurried C.mkFn $ \ss1 ss2 ss3 args il ->
156− Function ss1 Nothing args (Block ss2 [Return ss3 il])
157−
158− mkEffFn :: Text -> Text -> Int -> AST -> AST
159− mkEffFn modName fnName = mkFn' modName fnName $ \ss1 ss2 ss3 args il ->
160− Function ss1 Nothing args (Block ss2 [Return ss3 (App ss3 il [])])
161−
162− mkFn' :: Text -> Text -> (Maybe SourceSpan -> Maybe SourceSpan -> Maybe SourceSpan -> [Text] -> AST -> AST) -> Int -> AST -> AST
163− mkFn' modName fnName res 0 = convert where
164− convert :: AST -> AST
165− convert (App _ mkFnN [Function s1 Nothing [_] (Block s2 [Return s3 il])]) | isNFn modName fnName 0 mkFnN =
166− res s1 s2 s3 [] il
167− convert other = other
168− mkFn' modName fnName res n = convert where
169− convert :: AST -> AST
170− convert orig@(App ss mkFnN [fn]) | isNFn modName fnName n mkFnN =
171− case collectArgs n [] fn of
172− Just (args, [Return ss' ret]) -> res ss ss ss' args ret
173− _ -> orig
174− convert other = other
175− collectArgs :: Int -> [Text] -> AST -> Maybe ([Text], [AST])
176− collectArgs 1 acc (Function _ Nothing [oneArg] (Block _ il)) | length acc == n - 1 = Just (reverse (oneArg : acc), il)
177− collectArgs m acc (Function _ Nothing [oneArg] (Block _ [Return _ ret])) = collectArgs (m - 1) (oneArg : acc) ret
178− collectArgs _ _ _ = Nothing
179−
180− isNFn :: Text -> Text -> Int -> AST -> Bool
181− isNFn expectMod prefix n (Indexer _ (Var _ name) (Var _ modName)) | modName == expectMod =
182− name == fromString (T.unpack prefix <> show n)
183− isNFn _ _ _ _ = False
184−
185− runFn :: Int -> AST -> AST
186− runFn = runFn' C.dataFunctionUncurried C.runFn (\ss f args ->
187− let len = length args
188− typ = mkString $ uncurriedFnType len in
189− if len > 0
190− then App ss (App Nothing (StringLiteral Nothing typ) [f]) args
191− else App ss f args)
192− runEffFn :: Text -> Text -> Int -> AST -> AST
193− runEffFn modName fnName = runFn' modName fnName $ \ss fn acc ->
194− let typ = mkString . uncurriedFnType $ length acc in
195− Function ss Nothing [] (Block ss [Return ss (App ss (App Nothing (StringLiteral Nothing typ) [fn]) acc)])
196−
197− runFn' :: Text -> Text -> (Maybe SourceSpan -> AST -> [AST] -> AST) -> Int -> AST -> AST
198− runFn' modName runFnName res n = convert where
199− convert :: AST -> AST
200− convert il = fromMaybe il $ go n [] il
201−
202− go :: Int -> [AST] -> AST -> Maybe AST
203− go 0 acc (App ss runFnN [fn]) | isNFn modName runFnName n runFnN && length acc == n =
204− Just $ res ss fn acc
205− go m acc (App _ lhs [arg]) = go (m - 1) (arg : acc) lhs
206− go _ _ _ = Nothing
207−
208− inlineNonClassFunction :: (AST -> Bool) -> (AST -> AST -> AST) -> AST -> AST
209− inlineNonClassFunction p f = convert where
210− convert :: AST -> AST
211− convert (App _ (App _ op' [x]) [y]) | p op' = f x y
212− convert other = other
213−
214− inlineUnsafeIndex :: (AST -> Bool) -> (AST -> AST -> AST) -> AST -> AST
215− inlineUnsafeIndex p _ = convert where
216− convert :: AST -> AST
217− convert (App _ (App ss op' [x]) [y@NumericLiteral{}])
218− | p op' = Indexer ss y x
219− convert (App _ (App ss op' [x]) [y])
220− | p op' = App ss (Var Nothing indexFn) [x, y]
221− convert other = other
222−
223− isModFn :: (Text, PSString) -> AST -> Bool
224− isModFn (m, op) (Indexer _ (Var _ op') (Var _ m')) =
225− m == m' && decodeString op == Just op'
226− isModFn _ _ = False
227−
228− isModFnWithDict :: (Text, PSString) -> AST -> Bool
229− isModFnWithDict (m, op) (App _ (Indexer _ (Var _ op') (Var _ m')) [Var _ _]) =
230− m == m' && decodeString op == Just op'
231− isModFnWithDict _ _ = False
232−
233−-- (f <<< g $ x) = f (g x)
234−-- (f <<< g) = \x -> f (g x)
235−inlineFnComposition :: forall m. MonadSupply m => AST -> m AST
236−inlineFnComposition = everywhereTopDownM convert where
237− convert :: AST -> m AST
238− convert (App s1 (App s2 (App _ (App _ fn [dict']) [x]) [y]) [z])
239− | isFnCompose dict' fn = return $ App s1 x [App s2 y [z]]
240− | isFnComposeFlipped dict' fn = return $ App s2 y [App s1 x [z]]
241− convert app@(App ss (App _ (App _ fn [dict']) _) _)
242− | isFnCompose dict' fn || isFnComposeFlipped dict' fn = mkApps ss <$> goApps app <*> freshName'
243− convert other = return other
244−
245− mkApps :: Maybe SourceSpan -> [Either AST (Text, AST)] -> Text -> AST
246− mkApps ss fns a = App ss (Function ss Nothing [] (Block ss $ vars <> [Return Nothing comp])) []
247− where
248− vars = uncurry (VariableIntroduction ss) . fmap Just <$> rights fns
249− comp = Function ss Nothing [a] (Block ss [Return Nothing apps])
250− apps = foldr (\fn acc -> App ss (mkApp fn) [acc]) (Var ss a) fns
251−
252− mkApp :: Either AST (Text, AST) -> AST
253− mkApp = either id $ \(name, arg) -> Var (getSourceSpan arg) name
254−
255− goApps :: AST -> m [Either AST (Text, AST)]
256− goApps (App _ (App _ (App _ fn [dict']) [x]) [y])
257− | isFnCompose dict' fn = mappend <$> goApps x <*> goApps y
258− | isFnComposeFlipped dict' fn = mappend <$> goApps y <*> goApps x
259− goApps app@(App {}) = pure . Right . (,app) <$> freshName'
260− goApps other = pure [Left other]
261−
262− isFnCompose :: AST -> AST -> Bool
263− isFnCompose dict' fn = isDict semigroupoidFn dict' && isDict fnCompose fn
264−
265− isFnComposeFlipped :: AST -> AST -> Bool
266− isFnComposeFlipped dict' fn = isDict semigroupoidFn dict' && isDict fnComposeFlipped fn
267−
268− fnCompose :: forall a b. (IsString a, IsString b) => (a, b)
269− fnCompose = (C.controlSemigroupoid, C.compose)
270−
271− fnComposeFlipped :: forall a b. (IsString a, IsString b) => (a, b)
272− fnComposeFlipped = (C.controlSemigroupoid, C.composeFlipped)
273−
274−inlineUnsafeCoerce :: AST -> AST
275−inlineUnsafeCoerce = everywhereTopDown convert where
276− convert (App _ (Indexer _ (Var _ unsafeCoerceFn) (Var _ unsafeCoerce)) [ comp ])
277− | unsafeCoerceFn == C.unsafeCoerceFn && unsafeCoerce == C.unsafeCoerce
278− = comp
279− convert other = other
280−
281−inlineUnsafePartial :: AST -> AST
282−inlineUnsafePartial = everywhereTopDown convert where
283− convert (App ss fn [ comp ])
284− | isDict fnUnsafePartial fn
285− = App ss comp []
286− where
287− fnUnsafePartial :: forall a b. (IsString a, IsString b) => (a, b)
288− fnUnsafePartial = (C.partialUnsafe, C.unsafePartial)
289− convert other = other
290−
291−semiringNumber :: forall a b. (IsString a, IsString b) => (a, b)
292−semiringNumber = (C.dataSemiring, C.semiringNumber)
293−
294−semiringInt :: forall a b. (IsString a, IsString b) => (a, b)
295−semiringInt = (C.dataSemiring, C.semiringInt)
296−
297−ringNumber :: forall a b. (IsString a, IsString b) => (a, b)
298−ringNumber = (C.dataRing, C.ringNumber)
299−
300−ringInt :: forall a b. (IsString a, IsString b) => (a, b)
301−ringInt = (C.dataRing, C.ringInt)
302−
303−euclideanRingNumber :: forall a b. (IsString a, IsString b) => (a, b)
304−euclideanRingNumber = (C.dataEuclideanRing, C.euclideanRingNumber)
305−
306−-- eqNumber :: forall a b. (IsString a, IsString b) => (a, b)
307−-- eqNumber = (C.dataEq, C.eqNumber)
308−
309−eqInt :: forall a b. (IsString a, IsString b) => (a, b)
310−eqInt = (C.dataEq, C.eqInt)
311−
312−eqString :: forall a b. (IsString a, IsString b) => (a, b)
313−eqString = (C.dataEq, C.eqString)
314−
315−eqChar :: forall a b. (IsString a, IsString b) => (a, b)
316−eqChar = (C.dataEq, C.eqChar)
317−
318−eqBoolean :: forall a b. (IsString a, IsString b) => (a, b)
319−eqBoolean = (C.dataEq, C.eqBoolean)
320−
321−ordBoolean :: forall a b. (IsString a, IsString b) => (a, b)
322−ordBoolean = (C.dataOrd, C.ordBoolean)
323−
324−ordNumber :: forall a b. (IsString a, IsString b) => (a, b)
325−ordNumber = (C.dataOrd, C.ordNumber)
326−
327−ordInt :: forall a b. (IsString a, IsString b) => (a, b)
328−ordInt = (C.dataOrd, C.ordInt)
329−
330−ordString :: forall a b. (IsString a, IsString b) => (a, b)
331−ordString = (C.dataOrd, C.ordString)
332−
333−ordChar :: forall a b. (IsString a, IsString b) => (a, b)
334−ordChar = (C.dataOrd, C.ordChar)
335−
336−semigroupString :: forall a b. (IsString a, IsString b) => (a, b)
337−semigroupString = (C.dataSemigroup, C.semigroupString)
338−
339−boundedBoolean :: forall a b. (IsString a, IsString b) => (a, b)
340−boundedBoolean = (C.dataBounded, C.boundedBoolean)
341−
342−heytingAlgebraBoolean :: forall a b. (IsString a, IsString b) => (a, b)
343−heytingAlgebraBoolean = (C.dataHeytingAlgebra, C.heytingAlgebraBoolean)
344−
345−semigroupoidFn :: forall a b. (IsString a, IsString b) => (a, b)
346−semigroupoidFn = (C.controlSemigroupoid, C.semigroupoidFn)
347−
348−opAdd :: forall a b. (IsString a, IsString b) => (a, b)
349−opAdd = (C.dataSemiring, C.add)
350−
351−opMul :: forall a b. (IsString a, IsString b) => (a, b)
352−opMul = (C.dataSemiring, C.mul)
353−
354−opEq :: forall a b. (IsString a, IsString b) => (a, b)
355−opEq = (C.dataEq, C.eq)
356−
357−opNotEq :: forall a b. (IsString a, IsString b) => (a, b)
358−opNotEq = (C.dataEq, C.notEq)
359−
360−opLessThan :: forall a b. (IsString a, IsString b) => (a, b)
361−opLessThan = (C.dataOrd, C.lessThan)
362−
363−opLessThanOrEq :: forall a b. (IsString a, IsString b) => (a, b)
364−opLessThanOrEq = (C.dataOrd, C.lessThanOrEq)
365−
366−opGreaterThan :: forall a b. (IsString a, IsString b) => (a, b)
367−opGreaterThan = (C.dataOrd, C.greaterThan)
368−
369−opGreaterThanOrEq :: forall a b. (IsString a, IsString b) => (a, b)
370−opGreaterThanOrEq = (C.dataOrd, C.greaterThanOrEq)
371−
372−opAppend :: forall a b. (IsString a, IsString b) => (a, b)
373−opAppend = (C.dataSemigroup, C.append)
374−
375−opSub :: forall a b. (IsString a, IsString b) => (a, b)
376−opSub = (C.dataRing, C.sub)
377−
378−opNegate :: forall a b. (IsString a, IsString b) => (a, b)
379−opNegate = (C.dataRing, C.negate)
380−
381−opDiv :: forall a b. (IsString a, IsString b) => (a, b)
382−opDiv = (C.dataEuclideanRing, C.div)
383−
384−opConj :: forall a b. (IsString a, IsString b) => (a, b)
385−opConj = (C.dataHeytingAlgebra, C.conj)
386−
387−opDisj :: forall a b. (IsString a, IsString b) => (a, b)
388−opDisj = (C.dataHeytingAlgebra, C.disj)
389−
390−opNot :: forall a b. (IsString a, IsString b) => (a, b)
391−opNot = (C.dataHeytingAlgebra, C.not)
392−
393−unbox :: AST -> PSString -> AST
394−unbox e d = select . inlineCommonValues $ inlineCommonOperators e
395− where
396− select :: AST -> AST
397− select e' =
398− case e' of
399− Var{} -> unbox' e'
400− App{} -> unbox' e'
401− Indexer{} -> unbox' e'
402− _ -> e'
403− unbox' :: AST -> AST
404− unbox' e' = maybe e' (\t -> App Nothing (StringLiteral Nothing t) [e']) $ unboxType d
405−
406−unboxType :: PSString -> Maybe PSString
407−unboxType s = do
408− t <- decodeString s
409− t' <- unboxType' t
410− return $ mkString t'
411− where
412− unboxType' :: Text -> Maybe Text
413− unboxType' t
414− | t == C.eqInt ||
415− t == C.semiringInt ||
416− t == C.ringInt ||
417− t == C.ordInt ||
418− t == C.dataIntBits
419− = Just int
420− | t == C.semiringNumber ||
421− t == C.ringNumber ||
422− t == C.ordNumber ||
423− t == C.euclideanRingNumber
424− = Just float
425− | t == C.eqBoolean ||
426− t == C.ordBoolean ||
427− t == C.heytingAlgebraBoolean
428− = Just bool
429− | t == C.eqChar ||
430− t == C.eqString ||
431− t == C.ordChar ||
432− t == C.ordString ||
433− t == C.semigroupString
434− = Just string
435− | otherwise = Nothing
src/CodeGen/IL/Optimizer/MagicDo.hsdeleted−146
@@ -1,146 +0,0 @@
1−-- | This module implements the "Magic Do" optimization, which inlines calls to return
2−-- and bind for the Eff monad, as well as some of its actions.
3−module CodeGen.IL.Optimizer.MagicDo (magicDoEffect, magicDoEff, magicDoST, inlineST) where
4−
5−import Prelude.Compat
6−import Protolude (ordNub)
7−
8−import Data.Maybe (fromJust, isJust)
9−import Data.Text (Text)
10−
11−import Language.PureScript.CoreImp.AST
12−import Language.PureScript.CoreImp.Optimizer.Common hiding (isDict)
13−import Language.PureScript.PSString (PSString, decodeString, mkString)
14−import qualified Language.PureScript.Constants as C
15−
16−import CodeGen.IL.Common (undefinedName, unusedName)
17−import CodeGen.IL.Optimizer.Common
18−
19−-- | Inline type class dictionaries for >>= and return for the Eff monad
20−--
21−-- E.g.
22−--
23−-- Prelude[">>="](dict)(m1)(function(x) {
24−-- return ...;
25−-- })
26−--
27−-- becomes
28−--
29−-- function __do {
30−-- var x = m1();
31−-- ...
32−-- }
33−magicDoEff :: AST -> AST
34−magicDoEff = magicDo C.eff C.effDictionaries
35−
36−magicDoEffect :: AST -> AST
37−magicDoEffect = magicDo C.effect C.effectDictionaries
38−
39−magicDoST :: AST -> AST
40−magicDoST = magicDo C.st C.stDictionaries
41−
42−magicDo :: Text -> C.EffectDictionaries -> AST -> AST
43−magicDo effectModule C.EffectDictionaries{..} = everywhereTopDown convert
44− where
45− -- Desugar monomorphic calls to >>= and return for the Eff monad
46− convert :: AST -> AST
47− -- Desugar pure
48− convert (App _ (App _ pure' [val]) []) | isPure pure' = val
49− -- Desugar discard
50− convert (App _ (App _ bind [m]) [Function s1 Nothing [unused] (Block s2 il)]) | isDiscard bind && unused == unusedName =
51− Function s1 Nothing [] $ Block s2 (App s2 m [] : map applyReturns il )
52− -- Desugar bind
53− convert (App _ (App _ bind [m]) [Function s1 Nothing [arg] (Block s2 il)]) | isBind bind =
54− Function s1 Nothing [] $ Block s2 (VariableIntroduction s2 arg (Just (App s2 m [])) : map applyReturns il)
55− -- Desugar untilE
56− convert (App s1 (App _ f [arg]) []) | isEffFunc edUntil f =
57− App s1 (Function s1 Nothing [] (Block s1 [ While s1 (Unary s1 Not (App s1 arg [])) (Block s1 []), Return s1 $ ObjectLiteral s1 []])) []
58− -- Desugar whileE
59− convert (App _ (App _ (App s1 f [arg1]) [arg2]) []) | isEffFunc edWhile f =
60− App s1 (Function s1 Nothing [] (Block s1 [ While s1 (App s1 arg1 []) (Block s1 [ App s1 arg2 [] ]), Return s1 $ ObjectLiteral s1 []])) []
61− -- -- Inline __do returns
62− -- convert (Return _ (App _ (Function _ (Just ident) [] body) [])) | ident == fnName = body
63− -- Inline double applications
64− convert (App _ (App s1 (Function s2 Nothing [] (Block ss body)) []) []) =
65− App s1 (Function s2 Nothing [] (Block ss (applyReturns `fmap` body))) []
66− convert other = other
67− -- Check if an expression represents a monomorphic call to >>= for the Eff monad
68− isBind (App _ fn [dict]) | isDict (effectModule, edBindDict) dict && isBindPoly fn = True
69− isBind _ = False
70− -- Check if an expression represents a call to @discard@
71− isDiscard (App _ (App _ fn [dict1]) [dict2])
72− | isDict (C.controlBind, C.discardUnitDictionary) dict1 &&
73− isDict (effectModule, edBindDict) dict2 &&
74− isDiscardPoly fn = True
75− isDiscard _ = False
76−
77− -- Check if an expression represents a monomorphic call to pure or return for the Eff applicative
78− isPure (App _ fn [dict]) | isDict (effectModule, edApplicativeDict) dict && isPurePoly fn = True
79− isPure _ = False
80− -- Check if an expression represents the polymorphic >>= function
81− isBindPoly = isDict (C.controlBind, C.bind)
82− -- Check if an expression represents the polymorphic pure function
83− isPurePoly = isDict (C.controlApplicative, C.pure')
84− -- Check if an expression represents the polymorphic discard function
85− isDiscardPoly = isDict (C.controlBind, C.discard)
86− -- Check if an expression represents a function in the Effect module
87− isEffFunc name (Indexer _ (StringLiteral _ name') (Var _ eff)) = eff == effectModule && name == name'
88− isEffFunc _ _ = False
89−
90− applyReturns :: AST -> AST
91− applyReturns (Return ss ret) = Return ss (App ss ret [])
92− applyReturns (Block ss ils) = Block ss (map applyReturns ils)
93− applyReturns (While ss cond il) = While ss cond (applyReturns il)
94− applyReturns (For ss v lo hi il) = For ss v lo hi (applyReturns il)
95− applyReturns (ForIn ss v xs il) = ForIn ss v xs (applyReturns il)
96− applyReturns (IfElse ss cond t f) = IfElse ss cond (applyReturns t) (applyReturns `fmap` f)
97− applyReturns other = other
98−
99−-- | Inline functions in the ST module
100−inlineST :: AST -> AST
101−inlineST = everywhere convertBlock
102− where
103− -- Look for runST blocks and inline the STRefs there.
104− -- If all STRefs are used in the scope of the same runST, only using { read, write, modify }STRef then
105− -- we can be more aggressive about inlining, and actually turn STRefs into local variables.
106− convertBlock (App s1 f [arg]) | isSTFunc C.runST f =
107− let refs = ordNub . findSTRefsIn $ arg
108− usages = findAllSTUsagesIn arg
109− allUsagesAreLocalVars = all (\u -> let v = toVar u in isJust v && fromJust v `elem` refs) usages
110− localVarsDoNotEscape = all (\r -> length (r `appearingIn` arg) == length (filter (\u -> let v = toVar u in v == Just r) usages)) refs
111− in App s1 (everywhere (convert (allUsagesAreLocalVars && localVarsDoNotEscape)) arg) []
112− convertBlock other = other
113− -- Convert a block in a safe way, preserving object wrappers of references,
114− -- or in a more aggressive way, turning wrappers into local variables depending on the
115− -- agg(ressive) parameter.
116− convert agg (App s1 f [arg]) | isSTFunc C.newSTRef f =
117− Function s1 Nothing [] (Block s1 [Return s1 $ if agg then arg else ObjectLiteral s1 [(mkString C.stRefValue, arg)]])
118− convert agg (App _ (App s1 f [ref]) []) | isSTFunc C.readSTRef f =
119− if agg then ref else Indexer s1 (StringLiteral s1 C.stRefValue) ref
120− convert agg (App _ (App _ (App s1 f [arg]) [ref]) []) | isSTFunc C.writeSTRef f =
121− if agg then Assignment s1 ref arg else Assignment s1 (Indexer s1 (StringLiteral s1 C.stRefValue) ref) arg
122− convert agg (App _ (App _ (App s1 f [func]) [ref]) []) | isSTFunc C.modifySTRef f =
123− if agg then Assignment s1 ref (App s1 func [ref]) else Assignment s1 (Indexer s1 (StringLiteral s1 C.stRefValue) ref) (App s1 func [Indexer s1 (StringLiteral s1 C.stRefValue) ref])
124− convert _ other = other
125− -- Check if an expression represents a function in the ST module
126− isSTFunc name (Indexer _ (StringLiteral _ name') (Var _ st)) = st == C.st && name == name'
127− isSTFunc _ _ = False
128− -- Find all ST Refs initialized in this block
129− findSTRefsIn = everything (++) isSTRef
130− where
131− isSTRef (VariableIntroduction _ ident (Just (App _ (App _ f [_]) []))) | isSTFunc C.newSTRef f = [ident]
132− isSTRef _ = []
133− -- Find all STRefs used as arguments to readSTRef, writeSTRef, modifySTRef
134− findAllSTUsagesIn = everything (++) isSTUsage
135− where
136− isSTUsage (App _ (App _ f [ref]) []) | isSTFunc C.readSTRef f = [ref]
137− isSTUsage (App _ (App _ (App _ f [_]) [ref]) []) | isSTFunc C.writeSTRef f || isSTFunc C.modifySTRef f = [ref]
138− isSTUsage _ = []
139− -- Find all uses of a variable
140− appearingIn ref = everything (++) isVar
141− where
142− isVar e@(Var _ v) | v == ref = [e]
143− isVar _ = []
144− -- Convert a AST value to a String if it is a Var
145− toVar (Var _ v) = Just v
146− toVar _ = Nothing
src/CodeGen/IL/Optimizer/TCO.hsdeleted−141
@@ -1,141 +0,0 @@
1−module CodeGen.IL.Optimizer.TCO (tco, tcoLoop) where
2−
3−import Prelude.Compat
4−
5−import Data.Text (Text)
6−import Data.Monoid ((<>))
7−import Language.PureScript.CoreImp.AST
8−import Language.PureScript.AST.SourcePos (SourceSpan)
9−import Safe (headDef, tailSafe)
10−import CodeGen.IL.Common
11−
12−import qualified Language.PureScript.Constants as C
13−
14−tcoLoop :: Text
15−tcoLoop = "ṩtco_loop"
16−
17−tco :: AST -> AST -> AST
18−tco mn = everywhere convert where
19− tcoVar :: Text -> Text
20− tcoVar arg = "ṩtco_var_" <> arg
21−
22− copyVar :: Text -> Text
23− copyVar arg = "ṩcopy_" <> arg
24−
25− tcoDone :: Text
26− tcoDone = "ṩtco_done"
27−
28− tcoResult :: Text
29− tcoResult = "ṩtco_result"
30−
31− convert :: AST -> AST
32− convert fn@(Function ss (Just name) args _)
33− | isTailRecursive name body'
34− = replace (toLoop name outerArgs innerArgs body')
35− where
36− innerArgs = headDef [] argss
37− outerArgs = concat . reverse $ tailSafe argss
38− (argss, body', replace) = collectAllFunctionArgs [] id fn
39− convert (Assignment ss (Var _ name) fn@(Function _ Nothing _ _))
40− | isTailRecursive name body'
41− = Assignment ss (Var ss name) (replace (toLoop name outerArgs innerArgs body'))
42− where
43− innerArgs = headDef [] argss
44− outerArgs = concat . reverse $ tailSafe argss
45− (argss, body', replace) = collectAllFunctionArgs [] id fn
46− convert js = js
47−
48− collectAllFunctionArgs :: [[Text]] -> (AST -> AST) -> AST -> ([[Text]], AST, AST -> AST)
49− collectAllFunctionArgs allArgs f (Function s1 ident args (Block s2 (body@(Return _ _):_))) =
50− collectAllFunctionArgs (args : allArgs) (\b -> f (Function s1 ident (map copyVar args) (Block s2 [b]))) body
51− collectAllFunctionArgs allArgs f (Function ss ident args body@(Block _ _)) =
52− (args : allArgs, body, f . Function ss ident (map copyVar args))
53− collectAllFunctionArgs allArgs f (Return s1 (Function s2 ident args (Block s3 [body]))) =
54− collectAllFunctionArgs (args : allArgs) (\b -> f (Return s1 (Function s2 ident (map copyVar args) (Block s3 [b])))) body
55− collectAllFunctionArgs allArgs f (Return s1 (Function s2 ident args body@(Block _ _))) =
56− (args : allArgs, body, f . Return s1 . Function s2 ident (map copyVar args))
57− collectAllFunctionArgs allArgs f body = (allArgs, body, f)
58−
59− isTailRecursive :: Text -> AST -> Bool
60− isTailRecursive ident js = countSelfReferences js > 0 && allInTailPosition js where
61− countSelfReferences = everything (+) match where
62− match :: AST -> Int
63− match (Var _ ident') | ident == ident' = 1
64− match _ = 0
65−
66− allInTailPosition (Return _ expr)
67− | isSelfCall ident expr = countSelfReferences expr == 1
68− | otherwise = countSelfReferences expr == 0
69− allInTailPosition (While _ js1 body)
70− = countSelfReferences js1 == 0 && allInTailPosition body
71− allInTailPosition (For _ _ js1 js2 body)
72− = countSelfReferences js1 == 0 && countSelfReferences js2 == 0 && allInTailPosition body
73− allInTailPosition (ForIn _ _ js1 body)
74− = countSelfReferences js1 == 0 && allInTailPosition body
75− allInTailPosition (IfElse _ js1 body el)
76− = countSelfReferences js1 == 0 && allInTailPosition body && all allInTailPosition el
77− allInTailPosition (Block _ body)
78− = all allInTailPosition body
79− allInTailPosition (Throw _ js1)
80− = countSelfReferences js1 == 0
81− allInTailPosition (ReturnNoResult _)
82− = True
83− allInTailPosition (VariableIntroduction _ _ js1)
84− = all ((== 0) . countSelfReferences) js1
85− allInTailPosition (Assignment _ _ js1)
86− = countSelfReferences js1 == 0
87− allInTailPosition (Comment _ _ js1)
88− = allInTailPosition js1
89− allInTailPosition _
90− = False
91−
92− toLoop :: Text -> [Text] -> [Text] -> AST -> AST
93− toLoop ident outerArgs innerArgs js =
94− Block rootSS $
95− concatMap (\arg -> [ VariableIntroduction rootSS (tcoVar arg) . Just $
96− Var rootSS (copyVar arg) ]) (outerArgs ++ innerArgs) ++
97− [ Assignment rootSS (Var rootSS $ "var " <> tcoDone) $ BooleanLiteral Nothing False
98− , VariableIntroduction rootSS tcoResult Nothing
99− , Assignment rootSS (Var rootSS $ "var " <> tcoLoop) (Function rootSS (Just tcoLoop) (outerArgs ++ innerArgs) (Block rootSS [loopify js]))
100− , While rootSS (Unary Nothing Not (Var rootSS tcoDone))
101− (Block rootSS
102− [(Assignment rootSS (Var rootSS tcoResult) (App rootSS (Var rootSS tcoLoop) ((map (Var rootSS . tcoVar) outerArgs) ++ (map (Var rootSS . copyVar) innerArgs))))])
103− , Return rootSS (Var rootSS tcoResult)
104− ]
105− where
106− rootSS = Nothing
107−
108− loopify :: AST -> AST
109− loopify (Return ss ret)
110− | isSelfCall ident ret =
111− let
112− allArgumentValues = concat $ collectArgs [] ret
113− in
114− Block ss $
115− zipWith (\val arg ->
116− Assignment ss (Var ss (tcoVar arg)) val) allArgumentValues outerArgs
117− ++ zipWith (\val arg ->
118− Assignment ss (Var ss (copyVar arg)) val) (drop (length outerArgs) allArgumentValues) innerArgs
119− ++ [ ReturnNoResult ss ]
120− | otherwise = Block ss [ markDone ss, Return ss ret ]
121− loopify (ReturnNoResult ss) = Block ss [ markDone ss, ReturnNoResult ss ]
122− loopify (While ss cond body) = While ss cond (loopify body)
123− loopify (For ss i js1 js2 body) = For ss i js1 js2 (loopify body)
124− loopify (ForIn ss i js1 body) = ForIn ss i js1 (loopify body)
125− loopify (IfElse ss cond body el) = IfElse ss cond (loopify body) (fmap loopify el)
126− loopify (Block ss body) = Block ss (map loopify body)
127− loopify other = other
128−
129− markDone :: Maybe SourceSpan -> AST
130− markDone ss = Assignment ss (Var ss tcoDone) (BooleanLiteral ss True)
131−
132− collectArgs :: [[AST]] -> AST -> [[AST]]
133− collectArgs acc (App _ fn args') = collectArgs (args' : acc) fn
134− collectArgs acc _ = acc
135−
136− isSelfCall :: Text -> AST -> Bool
137− isSelfCall ident (App _ (Var _ ident') _) = ident == ident'
138− isSelfCall ident (App _ (Indexer _ (Var _ ident') (Var _ mn')) _) = mn' == "" && ident == ident'
139− isSelfCall ident (App _ (Indexer _ (Var _ ident') mn') _) = mn' == mn && ident == ident'
140− isSelfCall ident (App _ fn _) = isSelfCall ident fn
141− isSelfCall _ _ = False
src/CodeGen/IL/Printer.hsdeleted−527
@@ -1,527 +0,0 @@
1−-- | Pretty printer for the AST
2−module CodeGen.IL.Printer
3− ( prettyPrintIL
4− , prettyPrintIL1
5− , prettyPrintILWithSourceMaps
6− , interfaceSource
7− , implHeaderSource
8− , implFooterSource
9− , isLiteral
10− , modLabel
11− , modPrefix
12− , ffiLoader
13− ) where
14−
15−import Prelude.Compat
16−
17−import Control.Arrow ((<+>))
18−import Control.Monad (forM, mzero)
19−import Control.Monad.State (StateT, evalStateT)
20−import Control.PatternArrows
21−import Data.List (filter, (\\))
22−import qualified Control.Arrow as A
23−
24−import Data.Maybe (fromMaybe)
25−import Data.Monoid ((<>))
26−import Data.Text (Text)
27−import qualified Data.Text as T
28−
29−import Language.PureScript.AST (SourceSpan(..))
30−import Language.PureScript.CoreImp.AST
31−import Language.PureScript.Comments
32−import Language.PureScript.Crash
33−import Language.PureScript.Names (Ident, runIdent)
34−import Language.PureScript.Pretty.Common
35−import Language.PureScript.PSString (PSString, decodeString, mkString)
36−
37−import CodeGen.IL.Common
38−import CodeGen.IL.Optimizer.TCO (tcoLoop)
39−
40−import qualified Language.PureScript.Constants as C
41−
42−-- TODO (Christoph): Get rid of T.unpack / pack
43−
44−literals :: (Emit gen) => Pattern PrinterState AST gen
45−literals = mkPattern' match'
46− where
47− match' :: (Emit gen) => AST -> StateT PrinterState Maybe gen
48− match' il = (addMapping' (getSourceSpan il) <>) <$> match il
49−
50− match :: (Emit gen) => AST -> StateT PrinterState Maybe gen
51− match (NumericLiteral _ n) = return $ emit $ T.pack $ either show show n
52− match (StringLiteral _ s) = return $ emit $ stringLiteral s
53− match (BooleanLiteral _ True) = return $ emit "true"
54− match (BooleanLiteral _ False) = return $ emit "false"
55− match (ArrayLiteral _ xs) = mconcat <$> sequence
56− [ return . emit $ arrayType <> "{"
57− , intercalate (emit ", ") <$> forM xs prettyPrintIL'
58− , return $ emit "}"
59− ]
60− -- match (ObjectLiteral _ []) = return $ emit "std::initializer_list<std::pair<const string, boxed>>{}"
61− match (ObjectLiteral _ ps) = mconcat <$> sequence
62− [ return . emit $ dictType <> "{"
63− , withIndent $ do
64− ils <- forM ps $ \(key, value) -> do
65− value' <- prettyPrintIL' value
66− return $ objectPropertyToString key <> value'
67− return $ intercalate (emit " ") $ map (<> emit ",") ils
68− , return $ emit "}"
69− ]
70− where
71− objectPropertyToString :: (Emit gen) => PSString -> gen
72− objectPropertyToString s = emit $ stringLiteral s <> ": "
73− match (Block _ sts) = mconcat <$> sequence
74− [ return $ emit "{\n"
75− , withIndent $ prettyStatements sts
76− , return $ emit "\n"
77− , currentIndent
78− , return $ emit "}"
79− ]
80− match (Var _ ident) | ident == C.undefined = return $ emit undefinedName
81− match (Var _ ident) = return $ emit ident
82− match (VariableIntroduction _ ident value) = mconcat <$> sequence
83− [ return . emit $ varDecl <> " " <> ident <> " " <> anyType
84− , maybe (return mempty) (fmap (emit " = " <>) . prettyPrintIL') value
85− ]
86− match (Assignment _ target value) = mconcat <$> sequence
87− [ prettyPrintIL' target
88− , return $ emit " = "
89− , prettyPrintIL' value
90− ]
91− match (App _ val []) = mconcat <$> sequence
92− [ return $ emit "Run("
93− , prettyPrintIL' val
94− , return $ emit ")"
95− ]
96− match (App _ (StringLiteral _ u) [arg])
97− | Just ty <- decodeString u = mconcat <$> sequence
98− [ prettyPrintIL' arg
99− , return $ emit ".("
100− , return $ emit ty
101− , return $ emit ")"
102− ]
103− match (App _ (Var _ fn) [arg]) | fn == arrayLengthFn = mconcat <$> sequence
104− [ return $ emit fn
105− , return $ emit "("
106− , prettyPrintIL' arg
107− , return $ emit ")"
108− ]
109− match (App _ (Var _ fn) args) | fn == indexFn = mconcat <$> sequence
110− [ return $ emit fn
111− , return $ emit "("
112− , intercalate (emit ", ") <$> forM args prettyPrintIL'
113− , return $ emit ")"
114− ]
115− match (App _ (Var _ fn) args) | fn == tcoLoop = mconcat <$> sequence
116− [ return $ emit fn
117− , return $ emit "("
118− , intercalate (emit ", ") <$> forM args prettyPrintIL'
119− , return $ emit ")"
120− ]
121− match (App _ (App Nothing (StringLiteral Nothing fnx) [fn@Function{}]) args)
122− | Just ftype <- decodeString fnx
123− , "Fn" `T.isPrefixOf` ftype = mconcat <$> sequence
124− [ prettyPrintIL' fn
125− , return $ emit "("
126− , intercalate (emit ", ") <$> forM args prettyPrintIL'
127− , return $ emit ")"
128− ]
129− match (App _ (App Nothing (StringLiteral Nothing fnx) [fn]) args)
130− | Just ftype <- decodeString fnx
131− , "Fn" `T.isPrefixOf` ftype = mconcat <$> sequence
132− [ prettyPrintIL' fn
133− , return $ emit ".("
134− , return $ emit ftype
135− , return $ emit ")("
136− , intercalate (emit ", ") <$> forM args prettyPrintIL'
137− , return $ emit ")"
138− ]
139− match app@(App{})
140− | (val, args) <- unApp app []
141− , length args > 1
142− = mconcat <$> sequence
143− [ return $ emit "Apply("
144− , prettyPrintIL' val
145− , return $ emit ", "
146− , intercalate (emit ", ") <$> forM args prettyPrintIL'
147− , return $ emit ")"
148− ]
149− match (App _ val args) = mconcat <$> sequence
150− [ return $ emit "Apply("
151− , prettyPrintIL' val
152− , return $ emit ", "
153− , intercalate (emit ", ") <$> forM args prettyPrintIL'
154− , return $ emit ")"
155− ]
156− match (Function _ (Just name) [] (Block _ [Return _ ret]))
157− | isComplexLiteral ret = mconcat <$> sequence
158− [ return $ emit "\n"
159− , return . emit $ varDecl <> " " <> initName name <> " Once\n"
160− , prettyPrintIL' $ VariableIntroduction Nothing (valueName name) Nothing
161− , return $ emit "\n\n"
162− , return $ emit "func "
163− , return . emit $ withPrefix name
164− , return . emit $ "() " <> anyType <> " "
165− , return $ emit "{\n"
166− , withIndent $ do
167− indentString <- currentIndent
168− return $ indentString <> (emit $ initName name <> ".Do(func() {\n") <>
169− indentString <> indentString <> (emit $ valueName name <> " = ")
170− , withIndent $ do
171− case ret of
172− Function _ Nothing args body -> mconcat <$> sequence
173− [ return $ emit "func("
174− , return . emit $ intercalate ", " (renderArg anyType <$> args)
175− , return . emit $ ") " <> anyType <> " "
176− , prettyPrintIL' body
177− ]
178− _ -> do
179− prettyPrintIL' ret
180− , return $ emit "\n"
181− , withIndent $ do
182− indentString <- currentIndent
183− return $ indentString <> (emit $ "})\n" <> "return " <> valueName name <>"\n")
184− , return $ emit "}\n\n"
185− ]
186− match (Function _ (Just name) [] ret) = mconcat <$> sequence
187− [ return $ emit "func "
188− , return . emit $ withPrefix name
189− , return . emit $ "() " <> anyType <> " "
190− , prettyPrintIL' ret
191− ]
192− match (Function _ _ args ret) = mconcat <$> sequence
193− [ return $ emit "func("
194− , return . emit $ intercalate ", " (renderArg anyType <$> args)
195− , return . emit $ ") " <> anyType <> " "
196− , prettyPrintIL' ret
197− ]
198− match (Indexer _ (Var _ name) (Var _ "")) = mconcat <$> sequence
199− [ prettyPrintIL' (Var Nothing $ withPrefix name)
200− , return $ emit "()"
201− ]
202− match (Indexer _ (Var _ name) val) = mconcat <$> sequence
203− [ prettyPrintIL' val
204− , return $ emit "."
205− , prettyPrintIL' (Var Nothing $ withPrefix name)
206− , return $ emit "()"
207− ]
208− match (Indexer _ prop@StringLiteral{} val@ObjectLiteral{}) = mconcat <$> sequence
209− [ prettyPrintIL' val
210− , return $ emit "["
211− , prettyPrintIL' prop
212− , return $ emit "]"
213− ]
214− match (Indexer _ prop@StringLiteral{} val) = mconcat <$> sequence
215− [ prettyPrintIL' val
216− , return $ emit ".("
217− , return $ emit dictType
218− , return $ emit ")["
219− , prettyPrintIL' prop
220− , return $ emit "]"
221− ]
222− match (Indexer _ index val@ArrayLiteral{}) = mconcat <$> sequence
223− [ prettyPrintIL' val
224− , return $ emit "["
225− , prettyPrintIL' index
226− , return $ emit "]"
227− ]
228− match (Indexer _ index val) = mconcat <$> sequence
229− [ prettyPrintIL' val
230− , return $ emit ".("
231− , return $ emit arrayType
232− , return $ emit ")["
233− , prettyPrintIL' index
234− , return $ emit "]"
235− ]
236− match (InstanceOf _ val ty) = mconcat <$> sequence
237− [ return $ emit "Is("
238− , prettyPrintIL' val
239− , return $ emit ", "
240− , prettyPrintIL' ty
241− , return $ emit ")"
242− ]
243− match (While _ cond sts) = mconcat <$> sequence
244− [ return $ emit "for "
245− , prettyPrintIL' cond
246− , return $ emit " "
247− , prettyPrintIL' sts
248− ]
249− match (For _ ident start end sts) = mconcat <$> sequence
250− [ return $ emit $ "for var " <> ident <> " = "
251− , prettyPrintIL' start
252− , return $ emit $ "; " <> ident <> " < "
253− , prettyPrintIL' end
254− , return $ emit $ "; " <> ident <> "++ "
255− , prettyPrintIL' sts
256− ]
257− match (ForIn _ ident obj sts) = mconcat <$> sequence
258− [ return $ emit $ "for var " <> ident <> " in "
259− , prettyPrintIL' obj
260− , return $ emit " "
261− , prettyPrintIL' sts
262− ]
263− match (IfElse _ (Binary _ EqualTo cond@Binary{} (BooleanLiteral Nothing True)) thens elses) = mconcat <$> sequence
264− [ return $ emit "if "
265− , prettyPrintIL' cond
266− , return $ emit " "
267− , prettyPrintIL' thens
268− , maybe (return mempty) (fmap (emit " else " <>) . prettyPrintIL') elses
269− ]
270− match (IfElse _ (Binary _ EqualTo cond@Binary{} (BooleanLiteral Nothing False)) thens elses) = mconcat <$> sequence
271− [ return $ emit "if !("
272− , prettyPrintIL' cond
273− , return $ emit ") "
274− , prettyPrintIL' thens
275− , maybe (return mempty) (fmap (emit " else " <>) . prettyPrintIL') elses
276− ]
277− match (IfElse _ cond thens elses) = mconcat <$> sequence
278− [ return $ emit "if "
279− , prettyPrintIL' cond
280− , return $ emit " "
281− , prettyPrintIL' thens
282− , maybe (return mempty) (fmap (emit " else " <>) . prettyPrintIL') elses
283− ]
284− match (Return _ value) = mconcat <$> sequence
285− [ return $ emit "return "
286− , prettyPrintIL' value
287− ]
288− match (ReturnNoResult _) = return . emit $ "return " <> undefinedName
289− -- match (Throw _ _) = return mempty
290− match (Throw _ value) = mconcat <$> sequence
291− [ return $ emit "panic("
292− , prettyPrintIL' value
293− , return $ emit ")"
294− ]
295− match (Comment _ com il) = mconcat <$> sequence
296− [ return $ emit "\n"
297− , mconcat <$> forM com comment
298− , prettyPrintIL' il
299− ]
300− match _ = mzero
301−
302− comment :: (Emit gen) => Comment -> StateT PrinterState Maybe gen
303− comment (LineComment com) = fmap mconcat $ sequence $
304− [ currentIndent
305− , return $ emit "//" <> emit com <> emit "\n"
306− ]
307− comment (BlockComment com) = fmap mconcat $ sequence $
308− [ currentIndent
309− , return $ emit "/**\n"
310− ] ++
311− map asLine (T.lines com) ++
312− [ currentIndent
313− , return $ emit " */\n"
314− , currentIndent
315− ]
316− where
317− asLine :: (Emit gen) => Text -> StateT PrinterState Maybe gen
318− asLine s = do
319− i <- currentIndent
320− return $ i <> emit " * " <> (emit . removeComments) s <> emit "\n"
321−
322− removeComments :: Text -> Text
323− removeComments t =
324− case T.stripPrefix "*/" t of
325− Just rest -> removeComments rest
326− Nothing -> case T.uncons t of
327− Just (x, xs) -> x `T.cons` removeComments xs
328− Nothing -> ""
329−
330−unary' :: (Emit gen) => UnaryOperator -> (AST -> Text) -> Operator PrinterState AST gen
331−unary' op mkStr = Wrap match (<>)
332− where
333− match :: (Emit gen) => Pattern PrinterState AST (gen, AST)
334− match = mkPattern match'
335− where
336− match' (Unary _ op' val) | op' == op = Just (emit $ mkStr val, val)
337− match' _ = Nothing
338−
339−unary :: (Emit gen) => UnaryOperator -> Text -> Operator PrinterState AST gen
340−unary op str = unary' op (const str)
341−
342−negateOperator :: (Emit gen) => Operator PrinterState AST gen
343−negateOperator = unary' Negate (\v -> if isNegate v then "- " else "-")
344− where
345− isNegate (Unary _ Negate _) = True
346− isNegate _ = False
347−
348−binary :: (Emit gen) => BinaryOperator -> Text -> Operator PrinterState AST gen
349−binary op str = AssocL match (\v1 v2 -> v1 <> emit (" " <> str <> " ") <> v2)
350− where
351− match :: Pattern PrinterState AST (AST, AST)
352− match = mkPattern match'
353− where
354− match' (Binary _ op' v1 v2) | op' == op = Just (v1, v2)
355− match' _ = Nothing
356−
357−isLiteral :: AST -> Bool
358−isLiteral Function{} = True
359−isLiteral NumericLiteral{} = True
360−isLiteral StringLiteral{} = True
361−isLiteral BooleanLiteral{} = True
362−isLiteral ObjectLiteral{} = True
363−isLiteral ArrayLiteral{} = True
364−isLiteral _ = False
365−
366−isComplexLiteral :: AST -> Bool
367−-- isComplexLiteral Function{} = True
368−isComplexLiteral ObjectLiteral{} = True
369−isComplexLiteral ArrayLiteral{} = True
370−isComplexLiteral _ = False
371−
372−unApp :: AST -> [AST] -> (AST, [AST])
373−unApp (App _ val [arg]) args = unApp val (arg : args)
374−unApp other args = (other, args)
375−
376−prettyStatements :: (Emit gen) => [AST] -> StateT PrinterState Maybe gen
377−prettyStatements sts = do
378− ils <- forM sts prettyPrintIL'
379− indentString <- currentIndent
380− return $ intercalate (emit "\n") $ map (indentString <>) ils
381−
382−-- | Generate a pretty-printed string representing a collection of C++ expressions at the same indentation level
383−prettyPrintILWithSourceMaps :: [AST] -> (Text, [SMap])
384−prettyPrintILWithSourceMaps il =
385− let StrPos (_, s, mp) = (fromMaybe (internalError "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyStatements) il
386− in (s, mp)
387−
388−prettyPrintIL :: [AST] -> Text
389−prettyPrintIL = maybe (internalError "Incomplete pattern") runPlainString . flip evalStateT (PrinterState 0) . prettyStatements
390−
391−-- | Generate an indented, pretty-printed string representing a C++ expression
392−prettyPrintIL' :: (Emit gen) => AST -> StateT PrinterState Maybe gen
393−prettyPrintIL' = A.runKleisli $ runPattern matchValue
394− where
395− matchValue :: (Emit gen) => Pattern PrinterState AST gen
396− matchValue = buildPrettyPrinter operators (literals <+> fmap parensPos matchValue)
397− operators :: (Emit gen) => OperatorTable PrinterState AST gen
398− operators =
399− OperatorTable [ [ unary New "?" ]
400− , [ unary Not "!"
401− , unary BitwiseNot "~"
402− , unary Positive "+"
403− , negateOperator ]
404− , [ binary Multiply "*"
405− , binary Divide "/"
406− , binary Modulus "%" ]
407− , [ binary Add "+"
408− , binary Subtract "-" ]
409− , [ binary ShiftLeft "<<"
410− , binary ShiftRight ">>" ]
411− , [ binary LessThan "<"
412− , binary LessThanOrEqualTo "<="
413− , binary GreaterThan ">"
414− , binary GreaterThanOrEqualTo ">=" ]
415− , [ binary EqualTo "=="
416− , binary NotEqualTo "!=" ]
417− , [ binary BitwiseAnd "&" ]
418− , [ binary BitwiseXor "^" ]
419− , [ binary BitwiseOr "|" ]
420− , [ binary And "&&" ]
421− , [ binary Or "||" ]
422− ]
423−
424−prettyPrintIL1 :: AST -> Text
425−prettyPrintIL1 = maybe (internalError "Incomplete pattern") runPlainString . flip evalStateT (PrinterState 0) . prettyPrintIL'
426−
427−stringLiteral :: PSString -> Text
428−stringLiteral pss | Just s <- decodeString pss = stringLiteral' s
429− where
430− stringLiteral' :: Text -> Text
431− stringLiteral' s = "\"" <> T.concatMap encodeChar s <> "\""
432− encodeChar :: Char -> Text
433− encodeChar '\0' = "\\x00"
434− encodeChar '\b' = "\\b"
435− encodeChar '\t' = "\\t"
436− encodeChar '\n' = "\\n"
437− encodeChar '\v' = "\\v"
438− encodeChar '\f' = "\\f"
439− encodeChar '\r' = "\\r"
440− encodeChar '"' = "\\\""
441− encodeChar '\\' = "\\\\"
442− encodeChar c = T.singleton $ c
443−stringLiteral _ = "\"\\uFFFD\""
444−
445−interfaceSource :: Text -> [(Text,Bool)] -> [Ident] -> Text
446−interfaceSource _ _ _ = ""
447−
448−implHeaderSource :: Text -> [Text] -> Text -> Text
449−implHeaderSource mn imports otherPrefix =
450− "// Code generated by psgo. DO NOT EDIT.\n\n" <>
451− "package " <> (if mn == "Main" || mn == "Test_Main" then "main" else mn) <> "\n\n" <>
452− "import . \"" <> runtime <> "\"\n" <>
453− (if mn == "Main" || mn == "Test_Main"
454− then "import _ \"" <> otherPrefix <> "/" <> ffiLoader <> "\"\n"
455− else "\n") <>
456− "import (\n" <>
457− (T.concat $ formatImport <$> imports) <> ")\n\n" <>
458− "type _ = Any\n\n"
459− where
460− formatImport :: Text -> Text
461− formatImport s =
462− "\t\"" <> otherPrefix <> "/" <> modPrefix <> "/" <> moduleRenamer s <> "\"\n"
463− moduleRenamer :: Text -> Text
464− moduleRenamer s
465− | (s', sfx) <- T.breakOn moduleRenamerMarker s,
466− not $ T.null sfx = s'
467− moduleRenamer s = s
468−
469−implFooterSource :: Text -> [Ident] -> Text
470−implFooterSource mn foreigns =
471− "\n\n\n" <>
472− (if null foreigns
473− then ""
474− else ("// Foreign values\n\n" <>
475− "var " <> foreignDict <> " = "<> foreignMod <> "(\"" <> mn <> "\")\n\n" <>
476− (T.concat $ (\foreign' ->
477− let name = moduleIdentToIL foreign' in
478− varDecl <> " " <> initName name <> " Once\n" <>
479− varDecl <> " " <> valueName name <> " " <> anyType <> "\n\n" <>
480− "func " <>
481− withPrefix name <>
482− "() Any { \n" <>
483− " " <> initName name <> ".Do(func() {\n" <>
484− " " <> valueName name <> " = " <>
485− "Get(" <> foreignDict <> ", " <>
486− (stringLiteral . mkString $ runIdent foreign') <> ")\n" <>
487− " })\n" <>
488− " return " <> valueName name <> "\n" <>
489− "}\n\n") <$> foreigns))) <>
490− if mn == "Main" || mn == "Test.Main" then mainSource else "\n"
491− where
492− mainSource :: Text
493− mainSource = "\
494− \func main() {\n\
495− \ Run(Ꞌmain())\n\
496− \}\n\n\
497− \"
498−
499−varDecl :: Text
500−varDecl = "var"
501−
502−renderArg :: Text -> Text -> Text
503−renderArg decl arg = arg <> " " <> decl
504−
505−foreignMod :: Text
506−foreignMod = "Foreign"
507−
508−foreignDict :: Text
509−foreignDict = "foreign"
510−
511−modLabel :: Text
512−modLabel = "purescript-native"
513−
514−modPrefix :: Text
515−modPrefix = modLabel <> "/output"
516−
517−runtime :: Text
518−runtime = "github.com/" <> modLabel <> "/go-runtime"
519−
520−ffiLoader :: Text
521−ffiLoader = modLabel <> "/ffi-loader"
522−
523−initName :: Text -> Text
524−initName s = "ᛌ" <> s <> "_once"
525−
526−valueName :: Text -> Text
527−valueName s = "ᛧ" <> s
src/Language/PureScript.hsnew file+248
@@ -0,0 +1,248 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- The main compiler module
13+--
14+-----------------------------------------------------------------------------
15+
16+{-# LANGUAGE DataKinds, QuasiQuotes, TemplateHaskell #-}
17+
18+module Language.PureScript (module P, compile, compile', RebuildPolicy(..), MonadMake(..), make, prelude) where
19+
20+import Language.PureScript.Types as P
21+import Language.PureScript.Kinds as P
22+import Language.PureScript.AST as P
23+import Language.PureScript.Names as P
24+import Language.PureScript.Parser as P
25+import Language.PureScript.CodeGen as P
26+import Language.PureScript.CodeGen.Common as P
27+import Language.PureScript.TypeChecker as P
28+import Language.PureScript.Pretty as P
29+import Language.PureScript.Sugar as P
30+import Language.PureScript.Options as P
31+import Language.PureScript.ModuleDependencies as P
32+import Language.PureScript.Environment as P
33+import Language.PureScript.Errors as P
34+import Language.PureScript.DeadCodeElimination as P
35+import Language.PureScript.Supply as P
36+import Language.PureScript.Renamer as P
37+
38+import qualified Language.PureScript.Constants as C
39+
40+import Data.List (sortBy, groupBy, intercalate)
41+import Data.Time.Clock
42+import Data.Function (on)
43+import Data.Maybe (fromMaybe)
44+import Data.FileEmbed (embedFile)
45+import Data.Traversable (traverse)
46+
47+import Control.Monad.Error
48+import Control.Arrow ((&&&))
49+import Control.Applicative
50+
51+import qualified Data.Map as M
52+import qualified Data.Set as S
53+import qualified Data.ByteString.UTF8 as BU
54+
55+import System.FilePath ((</>))
56+
57+-- |
58+-- Compile a collection of modules
59+--
60+-- The compilation pipeline proceeds as follows:
61+--
62+-- * Sort the modules based on module dependencies, checking for cyclic dependencies.
63+--
64+-- * Perform a set of desugaring passes.
65+--
66+-- * Type check, and elaborate values to include type annotations and type class dictionaries.
67+--
68+-- * Regroup values to take into account new value dependencies introduced by elaboration.
69+--
70+-- * Eliminate dead code.
71+--
72+-- * Generate Javascript, and perform optimization passes.
73+--
74+-- * Pretty-print the generated Javascript
75+--
76+compile :: Options Compile -> [Module] -> [String] -> Either String (String, String, Environment)
77+compile = compile' initEnvironment
78+
79+compile' :: Environment -> Options Compile -> [Module] -> [String] -> Either String (String, String, Environment)
80+compile' env opts ms prefix = do
81+ (sorted, _) <- sortModules $ map importPrim $ if optionsNoPrelude opts then ms else (map importPrelude ms)
82+ (desugared, nextVar) <- stringifyErrorStack True $ runSupplyT 0 $ desugar sorted
83+ (elaborated, env') <- runCheck' opts env $ forM desugared $ typeCheckModule mainModuleIdent
84+ regrouped <- stringifyErrorStack True $ createBindingGroupsModule . collapseBindingGroupsModule $ elaborated
85+ let entryPoints = moduleNameFromString `map` entryPointModules (optionsAdditional opts)
86+ let elim = if null entryPoints then regrouped else eliminateDeadCode entryPoints regrouped
87+ let renamed = renameInModules elim
88+ let codeGenModuleNames = moduleNameFromString `map` codeGenModules (optionsAdditional opts)
89+ let modulesToCodeGen = if null codeGenModuleNames then renamed else filter (\(Module mn _ _) -> mn `elem` codeGenModuleNames) renamed
90+ let js = evalSupply nextVar $ concat <$> mapM (\m -> moduleToJs opts m env') modulesToCodeGen
91+ let exts = intercalate "\n" . map (`moduleToPs` env') $ modulesToCodeGen
92+ js' <- generateMain env' opts js
93+ let pjs = unlines $ map ("// " ++) prefix ++ [prettyPrintJS js']
94+ return (pjs, exts, env')
95+ where
96+ mainModuleIdent = moduleNameFromString <$> optionsMain opts
97+
98+generateMain :: Environment -> Options Compile -> [JS] -> Either String [JS]
99+generateMain env opts js =
100+ case moduleNameFromString <$> optionsMain opts of
101+ Just mmi -> do
102+ when ((mmi, Ident C.main) `M.notMember` names env) $
103+ Left $ show mmi ++ "." ++ C.main ++ " is undefined"
104+ return $ js ++ [JSApp (JSAccessor C.main (JSAccessor (moduleNameToJs mmi) (JSVar (browserNamespace (optionsAdditional opts))))) []]
105+ _ -> return js
106+
107+-- |
108+-- A type class which collects the IO actions we need to be able to run in "make" mode
109+--
110+class MonadMake m where
111+ -- |
112+ -- Get a file timestamp
113+ --
114+ getTimestamp :: FilePath -> m (Maybe UTCTime)
115+
116+ -- |
117+ -- Read a file as a string
118+ --
119+ readTextFile :: FilePath -> m String
120+
121+ -- |
122+ -- Write a text file
123+ --
124+ writeTextFile :: FilePath -> String -> m ()
125+
126+ -- |
127+ -- Report an error
128+ --
129+ liftError :: Either String a -> m a
130+
131+ -- |
132+ -- Respond to a progress update
133+ --
134+ progress :: String -> m ()
135+
136+-- |
137+-- Determines when to rebuild a module
138+--
139+data RebuildPolicy
140+ -- | Never rebuild this module
141+ = RebuildNever
142+ -- | Always rebuild this module
143+ | RebuildAlways deriving (Show, Eq, Ord)
144+
145+-- |
146+-- Compiles in "make" mode, compiling each module separately to a js files and an externs file
147+--
148+-- If timestamps have not changed, the externs file can be used to provide the module's types without
149+-- having to typecheck the module again.
150+--
151+make :: (Functor m, Applicative m, Monad m, MonadMake m) => FilePath -> Options Make -> [(Either RebuildPolicy FilePath, Module)] -> [String] -> m Environment
152+make outputDir opts ms prefix = do
153+ let filePathMap = M.fromList (map (\(fp, Module mn _ _) -> (mn, fp)) ms)
154+
155+ (sorted, graph) <- liftError $ sortModules $ map importPrim $ if optionsNoPrelude opts then map snd ms else (map (importPrelude . snd) ms)
156+
157+ toRebuild <- foldM (\s (Module moduleName' _ _) -> do
158+ let filePath = runModuleName moduleName'
159+
160+ jsFile = outputDir </> filePath </> "index.js"
161+ externsFile = outputDir </> filePath </> "externs.purs"
162+ inputFile = fromMaybe (error "Module has no filename in 'make'") $ M.lookup moduleName' filePathMap
163+
164+ jsTimestamp <- getTimestamp jsFile
165+ externsTimestamp <- getTimestamp externsFile
166+ inputTimestamp <- traverse getTimestamp inputFile
167+
168+ return $ case (inputTimestamp, jsTimestamp, externsTimestamp) of
169+ (Right (Just t1), Just t2, Just t3) | t1 < min t2 t3 -> s
170+ (Left RebuildNever, Just _, Just _) -> s
171+ _ -> S.insert moduleName' s) S.empty sorted
172+
173+ marked <- rebuildIfNecessary (reverseDependencies graph) toRebuild sorted
174+
175+ (desugared, nextVar) <- liftError $ stringifyErrorStack True $ runSupplyT 0 $ zip (map fst marked) <$> desugar (map snd marked)
176+
177+ evalSupplyT nextVar (go initEnvironment desugared)
178+
179+ where
180+ go :: (Functor m, Applicative m, Monad m, MonadMake m) => Environment -> [(Bool, Module)] -> SupplyT m Environment
181+ go env [] = return env
182+ go env ((False, m) : ms') = do
183+ (_, env') <- lift . liftError . runCheck' opts env $ typeCheckModule Nothing m
184+
185+ go env' ms'
186+ go env ((True, m@(Module moduleName' _ exps)) : ms') = do
187+ let filePath = runModuleName moduleName'
188+ jsFile = outputDir </> filePath </> "index.js"
189+ externsFile = outputDir </> filePath </> "externs.purs"
190+
191+ lift . progress $ "Compiling " ++ runModuleName moduleName'
192+
193+ (Module _ elaborated _, env') <- lift . liftError . runCheck' opts env $ typeCheckModule Nothing m
194+
195+ regrouped <- lift . liftError . stringifyErrorStack True . createBindingGroups moduleName' . collapseBindingGroups $ elaborated
196+
197+ let mod' = Module moduleName' regrouped exps
198+ let [renamed] = renameInModules [mod']
199+
200+ pjs <- prettyPrintJS <$> moduleToJs opts renamed env'
201+ let js = unlines $ map ("// " ++) prefix ++ [pjs]
202+ let exts = unlines $ map ("-- " ++ ) prefix ++ [moduleToPs renamed env']
203+
204+ lift $ writeTextFile jsFile js
205+ lift $ writeTextFile externsFile exts
206+
207+ go env' ms'
208+
209+ rebuildIfNecessary :: (Functor m, Monad m, MonadMake m) => M.Map ModuleName [ModuleName] -> S.Set ModuleName -> [Module] -> m [(Bool, Module)]
210+ rebuildIfNecessary _ _ [] = return []
211+ rebuildIfNecessary graph toRebuild (m@(Module moduleName' _ _) : ms') | moduleName' `S.member` toRebuild = do
212+ let deps = fromMaybe [] $ moduleName' `M.lookup` graph
213+ toRebuild' = toRebuild `S.union` S.fromList deps
214+ (:) (True, m) <$> rebuildIfNecessary graph toRebuild' ms'
215+ rebuildIfNecessary graph toRebuild (Module moduleName' _ _ : ms') = do
216+ let externsFile = outputDir </> runModuleName moduleName' </> "externs.purs"
217+ externs <- readTextFile externsFile
218+ externsModules <- liftError . either (Left . show) Right $ P.runIndentParser externsFile P.parseModules externs
219+ case externsModules of
220+ [m'@(Module moduleName'' _ _)] | moduleName'' == moduleName' -> (:) (False, m') <$> rebuildIfNecessary graph toRebuild ms'
221+ _ -> liftError . Left $ "Externs file " ++ externsFile ++ " was invalid"
222+
223+reverseDependencies :: ModuleGraph -> M.Map ModuleName [ModuleName]
224+reverseDependencies g = combine [ (dep, mn) | (mn, deps) <- g, dep <- deps ]
225+ where
226+ combine :: (Ord a) => [(a, b)] -> M.Map a [b]
227+ combine = M.fromList . map ((fst . head) &&& map snd) . groupBy ((==) `on` fst) . sortBy (compare `on` fst)
228+
229+-- |
230+-- Add an import declaration for a module if it does not already explicitly import it.
231+--
232+addDefaultImport :: ModuleName -> Module -> Module
233+addDefaultImport toImport m@(Module mn decls exps) =
234+ if isExistingImport `any` decls || mn == toImport then m
235+ else Module mn (ImportDeclaration toImport Unqualified Nothing : decls) exps
236+ where
237+ isExistingImport (ImportDeclaration mn' _ _) | mn' == toImport = True
238+ isExistingImport (PositionedDeclaration _ d) = isExistingImport d
239+ isExistingImport _ = False
240+
241+importPrim :: Module -> Module
242+importPrim = addDefaultImport (ModuleName [ProperName C.prim])
243+
244+importPrelude :: Module -> Module
245+importPrelude = addDefaultImport (ModuleName [ProperName C.prelude])
246+
247+prelude :: String
248+prelude = BU.toString $(embedFile "prelude/prelude.purs")
src/Language/PureScript/AST.hsnew file+23
@@ -0,0 +1,23 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.AST
4+-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- | The initial PureScript AST
12+--
13+-----------------------------------------------------------------------------
14+
15+module Language.PureScript.AST (
16+ module AST
17+) where
18+
19+import Language.PureScript.AST.Binders as AST
20+import Language.PureScript.AST.Declarations as AST
21+import Language.PureScript.AST.Operators as AST
22+import Language.PureScript.AST.SourcePos as AST
23+import Language.PureScript.AST.Traversals as AST
src/Language/PureScript/AST/Binders.hsnew file+86
@@ -0,0 +1,86 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.AST.Binders
4+-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- | Case binders
12+--
13+-----------------------------------------------------------------------------
14+
15+{-# LANGUAGE DeriveDataTypeable #-}
16+
17+module Language.PureScript.AST.Binders where
18+
19+import qualified Data.Data as D
20+
21+import Language.PureScript.AST.SourcePos
22+import Language.PureScript.Names
23+
24+-- |
25+-- Data type for binders
26+--
27+data Binder
28+ -- |
29+ -- Wildcard binder
30+ --
31+ = NullBinder
32+ -- |
33+ -- A binder which matches a boolean literal
34+ --
35+ | BooleanBinder Bool
36+ -- |
37+ -- A binder which matches a string literal
38+ --
39+ | StringBinder String
40+ -- |
41+ -- A binder which matches a numeric literal
42+ --
43+ | NumberBinder (Either Integer Double)
44+ -- |
45+ -- A binder which binds an identifier
46+ --
47+ | VarBinder Ident
48+ -- |
49+ -- A binder which matches a data constructor
50+ --
51+ | ConstructorBinder (Qualified ProperName) [Binder]
52+ -- |
53+ -- A binder which matches a record and binds its properties
54+ --
55+ | ObjectBinder [(String, Binder)]
56+ -- |
57+ -- A binder which matches an array and binds its elements
58+ --
59+ | ArrayBinder [Binder]
60+ -- |
61+ -- A binder which matches an array and binds its head and tail
62+ --
63+ | ConsBinder Binder Binder
64+ -- |
65+ -- A binder which binds its input to an identifier
66+ --
67+ | NamedBinder Ident Binder
68+ -- |
69+ -- A binder with source position information
70+ --
71+ | PositionedBinder SourcePos Binder deriving (Show, D.Data, D.Typeable)
72+
73+-- |
74+-- Collect all names introduced in binders in an expression
75+--
76+binderNames :: Binder -> [Ident]
77+binderNames = go []
78+ where
79+ go ns (VarBinder name) = name : ns
80+ go ns (ConstructorBinder _ bs) = foldl go ns bs
81+ go ns (ObjectBinder bs) = foldl go ns (map snd bs)
82+ go ns (ArrayBinder bs) = foldl go ns bs
83+ go ns (ConsBinder b1 b2) = go (go ns b1) b2
84+ go ns (NamedBinder name b) = go (name : ns) b
85+ go ns (PositionedBinder _ b) = go ns b
86+ go ns _ = ns
src/Language/PureScript/AST/Declarations.hsnew file+362
@@ -0,0 +1,362 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.AST.Declarations
4+-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- | Data types for modules and declarations
12+--
13+-----------------------------------------------------------------------------
14+
15+{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables #-}
16+
17+module Language.PureScript.AST.Declarations where
18+
19+import qualified Data.Data as D
20+
21+import Language.PureScript.AST.Binders
22+import Language.PureScript.AST.Operators
23+import Language.PureScript.AST.SourcePos
24+import Language.PureScript.Types
25+import Language.PureScript.Names
26+import Language.PureScript.Kinds
27+import Language.PureScript.TypeClassDictionaries
28+import Language.PureScript.CodeGen.JS.AST
29+import Language.PureScript.Environment
30+
31+-- |
32+-- A module declaration, consisting of a module name, a list of declarations, and a list of the
33+-- declarations that are explicitly exported. If the export list is Nothing, everything is exported.
34+--
35+data Module = Module ModuleName [Declaration] (Maybe [DeclarationRef]) deriving (Show, D.Data, D.Typeable)
36+
37+-- |
38+-- An item in a list of explicit imports or exports
39+--
40+data DeclarationRef
41+ -- |
42+ -- A type constructor with data constructors
43+ --
44+ = TypeRef ProperName (Maybe [ProperName])
45+ -- |
46+ -- A value
47+ --
48+ | ValueRef Ident
49+ -- |
50+ -- A type class
51+ --
52+ | TypeClassRef ProperName
53+ -- |
54+ -- A type class instance, created during typeclass desugaring (name, class name, instance types)
55+ --
56+ | TypeInstanceRef Ident
57+ -- |
58+ -- A declaration reference with source position information
59+ --
60+ | PositionedDeclarationRef SourcePos DeclarationRef
61+ deriving (Show, D.Data, D.Typeable)
62+
63+instance Eq DeclarationRef where
64+ (TypeRef name dctors) == (TypeRef name' dctors') = name == name' && dctors == dctors'
65+ (ValueRef name) == (ValueRef name') = name == name'
66+ (TypeClassRef name) == (TypeClassRef name') = name == name'
67+ (TypeInstanceRef name) == (TypeInstanceRef name') = name == name'
68+ (PositionedDeclarationRef _ r) == r' = r == r'
69+ r == (PositionedDeclarationRef _ r') = r == r'
70+ _ == _ = False
71+
72+-- |
73+-- The data type which specifies type of import declaration
74+--
75+data ImportDeclarationType
76+ -- |
77+ -- Unqualified import
78+ --
79+ = Unqualified
80+ -- |
81+ -- Qualified import with a list of references to import
82+ --
83+ | Qualifying [DeclarationRef]
84+ -- |
85+ -- Import with hiding clause with a list of references to hide
86+ --
87+ | Hiding [DeclarationRef]
88+ deriving (Show, D.Data, D.Typeable)
89+
90+-- |
91+-- The data type of declarations
92+--
93+data Declaration
94+ -- |
95+ -- A data type declaration (data or newtype, name, arguments, data constructors)
96+ --
97+ = DataDeclaration DataDeclType ProperName [(String, Maybe Kind)] [(ProperName, [Type])]
98+ -- |
99+ -- A minimal mutually recursive set of data type declarations
100+ --
101+ | DataBindingGroupDeclaration [Declaration]
102+ -- |
103+ -- A type synonym declaration (name, arguments, type)
104+ --
105+ | TypeSynonymDeclaration ProperName [(String, Maybe Kind)] Type
106+ -- |
107+ -- A type declaration for a value (name, ty)
108+ --
109+ | TypeDeclaration Ident Type
110+ -- |
111+ -- A value declaration (name, top-level binders, optional guard, value)
112+ --
113+ | ValueDeclaration Ident NameKind [Binder] (Either [(Guard, Expr)] Expr)
114+ -- |
115+ -- A minimal mutually recursive set of value declarations
116+ --
117+ | BindingGroupDeclaration [(Ident, NameKind, Expr)]
118+ -- |
119+ -- A foreign import declaration (type, name, optional inline Javascript, type)
120+ --
121+ | ExternDeclaration ForeignImportType Ident (Maybe JS) Type
122+ -- |
123+ -- A data type foreign import (name, kind)
124+ --
125+ | ExternDataDeclaration ProperName Kind
126+ -- |
127+ -- A type class instance foreign import
128+ --
129+ | ExternInstanceDeclaration Ident [(Qualified ProperName, [Type])] (Qualified ProperName) [Type]
130+ -- |
131+ -- A fixity declaration (fixity data, operator name)
132+ --
133+ | FixityDeclaration Fixity String
134+ -- |
135+ -- A module import (module name, qualified/unqualified/hiding, optional "qualified as" name)
136+ --
137+ | ImportDeclaration ModuleName ImportDeclarationType (Maybe ModuleName)
138+ -- |
139+ -- A type class declaration (name, argument, implies, member declarations)
140+ --
141+ | TypeClassDeclaration ProperName [(String, Maybe Kind)] [(Qualified ProperName, [Type])] [Declaration]
142+ -- |
143+ -- A type instance declaration (name, dependencies, class name, instance types, member
144+ -- declarations)
145+ --
146+ | TypeInstanceDeclaration Ident [(Qualified ProperName, [Type])] (Qualified ProperName) [Type] [Declaration]
147+ -- |
148+ -- A declaration with source position information
149+ --
150+ | PositionedDeclaration SourcePos Declaration
151+ deriving (Show, D.Data, D.Typeable)
152+
153+-- |
154+-- Test if a declaration is a value declaration
155+--
156+isValueDecl :: Declaration -> Bool
157+isValueDecl ValueDeclaration{} = True
158+isValueDecl (PositionedDeclaration _ d) = isValueDecl d
159+isValueDecl _ = False
160+
161+-- |
162+-- Test if a declaration is a data type or type synonym declaration
163+--
164+isDataDecl :: Declaration -> Bool
165+isDataDecl DataDeclaration{} = True
166+isDataDecl TypeSynonymDeclaration{} = True
167+isDataDecl (PositionedDeclaration _ d) = isDataDecl d
168+isDataDecl _ = False
169+
170+-- |
171+-- Test if a declaration is a module import
172+--
173+isImportDecl :: Declaration -> Bool
174+isImportDecl ImportDeclaration{} = True
175+isImportDecl (PositionedDeclaration _ d) = isImportDecl d
176+isImportDecl _ = False
177+
178+-- |
179+-- Test if a declaration is a data type foreign import
180+--
181+isExternDataDecl :: Declaration -> Bool
182+isExternDataDecl ExternDataDeclaration{} = True
183+isExternDataDecl (PositionedDeclaration _ d) = isExternDataDecl d
184+isExternDataDecl _ = False
185+
186+-- |
187+-- Test if a declaration is a type class instance foreign import
188+--
189+isExternInstanceDecl :: Declaration -> Bool
190+isExternInstanceDecl ExternInstanceDeclaration{} = True
191+isExternInstanceDecl (PositionedDeclaration _ d) = isExternInstanceDecl d
192+isExternInstanceDecl _ = False
193+
194+-- |
195+-- Test if a declaration is a fixity declaration
196+--
197+isFixityDecl :: Declaration -> Bool
198+isFixityDecl FixityDeclaration{} = True
199+isFixityDecl (PositionedDeclaration _ d) = isFixityDecl d
200+isFixityDecl _ = False
201+
202+-- |
203+-- Test if a declaration is a foreign import
204+--
205+isExternDecl :: Declaration -> Bool
206+isExternDecl ExternDeclaration{} = True
207+isExternDecl (PositionedDeclaration _ d) = isExternDecl d
208+isExternDecl _ = False
209+
210+-- |
211+-- Test if a declaration is a type class or instance declaration
212+--
213+isTypeClassDeclaration :: Declaration -> Bool
214+isTypeClassDeclaration TypeClassDeclaration{} = True
215+isTypeClassDeclaration TypeInstanceDeclaration{} = True
216+isTypeClassDeclaration (PositionedDeclaration _ d) = isTypeClassDeclaration d
217+isTypeClassDeclaration _ = False
218+
219+-- |
220+-- A guard is just a boolean-valued expression that appears alongside a set of binders
221+--
222+type Guard = Expr
223+
224+-- |
225+-- Data type for expressions and terms
226+--
227+data Expr
228+ -- |
229+ -- A numeric literal
230+ --
231+ = NumericLiteral (Either Integer Double)
232+ -- |
233+ -- A string literal
234+ --
235+ | StringLiteral String
236+ -- |
237+ -- A boolean literal
238+ --
239+ | BooleanLiteral Bool
240+ -- |
241+ -- A prefix -, will be desugared
242+ --
243+ | UnaryMinus Expr
244+ -- |
245+ -- Binary operator application. During the rebracketing phase of desugaring, this data constructor
246+ -- will be removed.
247+ --
248+ | BinaryNoParens (Qualified Ident) Expr Expr
249+ -- |
250+ -- Explicit parentheses. During the rebracketing phase of desugaring, this data constructor
251+ -- will be removed.
252+ --
253+ | Parens Expr
254+ -- |
255+ -- An array literal
256+ --
257+ | ArrayLiteral [Expr]
258+ -- |
259+ -- An object literal
260+ --
261+ | ObjectLiteral [(String, Expr)]
262+ -- |
263+ -- An record property accessor expression
264+ --
265+ | Accessor String Expr
266+ -- |
267+ -- Partial record update
268+ --
269+ | ObjectUpdate Expr [(String, Expr)]
270+ -- |
271+ -- Function introduction
272+ --
273+ | Abs (Either Ident Binder) Expr
274+ -- |
275+ -- Function application
276+ --
277+ | App Expr Expr
278+ -- |
279+ -- Variable
280+ --
281+ | Var (Qualified Ident)
282+ -- |
283+ -- Conditional (if-then-else expression)
284+ --
285+ | IfThenElse Expr Expr Expr
286+ -- |
287+ -- A data constructor
288+ --
289+ | Constructor (Qualified ProperName)
290+ -- |
291+ -- A case expression. During the case expansion phase of desugaring, top-level binders will get
292+ -- desugared into case expressions, hence the need for guards and multiple binders per branch here.
293+ --
294+ | Case [Expr] [CaseAlternative]
295+ -- |
296+ -- A value with a type annotation
297+ --
298+ | TypedValue Bool Expr Type
299+ -- |
300+ -- A let binding
301+ --
302+ | Let [Declaration] Expr
303+ -- |
304+ -- A do-notation block
305+ --
306+ | Do [DoNotationElement]
307+ -- |
308+ -- An application of a typeclass dictionary constructor. The value should be
309+ -- an ObjectLiteral.
310+ --
311+ | TypeClassDictionaryConstructorApp (Qualified ProperName) Expr
312+ -- |
313+ -- A placeholder for a type class dictionary to be inserted later. At the end of type checking, these
314+ -- placeholders will be replaced with actual expressions representing type classes dictionaries which
315+ -- can be evaluated at runtime. The constructor arguments represent (in order): whether or not to look
316+ -- at superclass implementations when searching for a dictionary, the type class name and
317+ -- instance type, and the type class dictionaries in scope.
318+ --
319+ | TypeClassDictionary Bool (Qualified ProperName, [Type]) [TypeClassDictionaryInScope]
320+ -- |
321+ -- A placeholder for a superclass dictionary to be turned into a TypeClassDictionary during typechecking
322+ --
323+ | SuperClassDictionary (Qualified ProperName) [Type]
324+ -- |
325+ -- A value with source position information
326+ --
327+ | PositionedValue SourcePos Expr deriving (Show, D.Data, D.Typeable)
328+
329+-- |
330+-- An alternative in a case statement
331+--
332+data CaseAlternative = CaseAlternative
333+ { -- |
334+ -- A collection of binders with which to match the inputs
335+ --
336+ caseAlternativeBinders :: [Binder]
337+ -- |
338+ -- The result expression or a collect of guarded expressions
339+ --
340+ , caseAlternativeResult :: Either [(Guard, Expr)] Expr
341+ } deriving (Show, D.Data, D.Typeable)
342+
343+-- |
344+-- A statement in a do-notation block
345+--
346+data DoNotationElement
347+ -- |
348+ -- A monadic value without a binder
349+ --
350+ = DoNotationValue Expr
351+ -- |
352+ -- A monadic value with a binder
353+ --
354+ | DoNotationBind Binder Expr
355+ -- |
356+ -- A let statement, i.e. a pure value with a binder
357+ --
358+ | DoNotationLet [Declaration]
359+ -- |
360+ -- A do notation element with source position information
361+ --
362+ | PositionedDoNotationElement SourcePos DoNotationElement deriving (Show, D.Data, D.Typeable)
src/Language/PureScript/AST/Operators.hsnew file+39
@@ -0,0 +1,39 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.AST.Operators
4+-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- | Operators fixity and associativity
12+--
13+-----------------------------------------------------------------------------
14+
15+{-# LANGUAGE DeriveDataTypeable #-}
16+
17+module Language.PureScript.AST.Operators where
18+
19+import qualified Data.Data as D
20+
21+-- |
22+-- A precedence level for an infix operator
23+--
24+type Precedence = Integer
25+
26+-- |
27+-- Associativity for infix operators
28+--
29+data Associativity = Infixl | Infixr | Infix deriving (D.Data, D.Typeable)
30+
31+instance Show Associativity where
32+ show Infixl = "infixl"
33+ show Infixr = "infixr"
34+ show Infix = "infix"
35+
36+-- |
37+-- Fixity data for infix operators
38+--
39+data Fixity = Fixity Associativity Precedence deriving (Show, D.Data, D.Typeable)
src/Language/PureScript/AST/SourcePos.hsnew file+40
@@ -0,0 +1,40 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.AST.SourcePos
4+-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- | Source position information
12+--
13+-----------------------------------------------------------------------------
14+
15+{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables #-}
16+
17+module Language.PureScript.AST.SourcePos where
18+
19+import qualified Data.Data as D
20+
21+-- |
22+-- Source position information
23+--
24+data SourcePos = SourcePos
25+ { -- |
26+ -- Source name
27+ --
28+ sourceName :: String
29+ -- |
30+ -- Line number
31+ --
32+ , sourcePosLine :: Int
33+ -- |
34+ -- Column number
35+ --
36+ , sourcePosColumn :: Int
37+ } deriving (D.Data, D.Typeable)
38+
39+instance Show SourcePos where
40+ show sp = sourceName sp ++ " line " ++ show (sourcePosLine sp) ++ ", column " ++ show (sourcePosColumn sp)
src/Language/PureScript/AST/Traversals.hsnew file+383
@@ -0,0 +1,383 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.AST.Traversals
4+-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- | AST traversal helpers
12+--
13+-----------------------------------------------------------------------------
14+
15+module Language.PureScript.AST.Traversals where
16+
17+import Data.Monoid (Monoid(..), mconcat)
18+
19+import Control.Applicative
20+import Control.Monad
21+import Control.Arrow ((***), (+++))
22+
23+import Language.PureScript.AST.Binders
24+import Language.PureScript.AST.Declarations
25+import Language.PureScript.Types
26+import Language.PureScript.Traversals
27+
28+everywhereOnValues :: (Declaration -> Declaration) ->
29+ (Expr -> Expr) ->
30+ (Binder -> Binder) ->
31+ (Declaration -> Declaration, Expr -> Expr, Binder -> Binder)
32+everywhereOnValues f g h = (f', g', h')
33+ where
34+ f' :: Declaration -> Declaration
35+ f' (DataBindingGroupDeclaration ds) = f (DataBindingGroupDeclaration (map f' ds))
36+ f' (ValueDeclaration name nameKind bs val) = f (ValueDeclaration name nameKind (map h' bs) ((map (g' *** g') +++ g') val))
37+ f' (BindingGroupDeclaration ds) = f (BindingGroupDeclaration (map (\(name, nameKind, val) -> (name, nameKind, g' val)) ds))
38+ f' (TypeClassDeclaration name args implies ds) = f (TypeClassDeclaration name args implies (map f' ds))
39+ f' (TypeInstanceDeclaration name cs className args ds) = f (TypeInstanceDeclaration name cs className args (map f' ds))
40+ f' (PositionedDeclaration pos d) = f (PositionedDeclaration pos (f' d))
41+ f' other = f other
42+
43+ g' :: Expr -> Expr
44+ g' (UnaryMinus v) = g (UnaryMinus (g' v))
45+ g' (BinaryNoParens op v1 v2) = g (BinaryNoParens op (g' v1) (g' v2))
46+ g' (Parens v) = g (Parens (g' v))
47+ g' (ArrayLiteral vs) = g (ArrayLiteral (map g' vs))
48+ g' (ObjectLiteral vs) = g (ObjectLiteral (map (fmap g') vs))
49+ g' (TypeClassDictionaryConstructorApp name v) = g (TypeClassDictionaryConstructorApp name (g' v))
50+ g' (Accessor prop v) = g (Accessor prop (g' v))
51+ g' (ObjectUpdate obj vs) = g (ObjectUpdate (g' obj) (map (fmap g') vs))
52+ g' (Abs name v) = g (Abs name (g' v))
53+ g' (App v1 v2) = g (App (g' v1) (g' v2))
54+ g' (IfThenElse v1 v2 v3) = g (IfThenElse (g' v1) (g' v2) (g' v3))
55+ g' (Case vs alts) = g (Case (map g' vs) (map handleCaseAlternative alts))
56+ g' (TypedValue check v ty) = g (TypedValue check (g' v) ty)
57+ g' (Let ds v) = g (Let (map f' ds) (g' v))
58+ g' (Do es) = g (Do (map handleDoNotationElement es))
59+ g' (PositionedValue pos v) = g (PositionedValue pos (g' v))
60+ g' other = g other
61+
62+ h' :: Binder -> Binder
63+ h' (ConstructorBinder ctor bs) = h (ConstructorBinder ctor (map h' bs))
64+ h' (ObjectBinder bs) = h (ObjectBinder (map (fmap h') bs))
65+ h' (ArrayBinder bs) = h (ArrayBinder (map h' bs))
66+ h' (ConsBinder b1 b2) = h (ConsBinder (h' b1) (h' b2))
67+ h' (NamedBinder name b) = h (NamedBinder name (h' b))
68+ h' (PositionedBinder pos b) = h (PositionedBinder pos (h' b))
69+ h' other = h other
70+
71+ handleCaseAlternative :: CaseAlternative -> CaseAlternative
72+ handleCaseAlternative ca =
73+ ca { caseAlternativeBinders = map h' (caseAlternativeBinders ca)
74+ , caseAlternativeResult = (map (g' *** g') +++ g') (caseAlternativeResult ca)
75+ }
76+
77+ handleDoNotationElement :: DoNotationElement -> DoNotationElement
78+ handleDoNotationElement (DoNotationValue v) = DoNotationValue (g' v)
79+ handleDoNotationElement (DoNotationBind b v) = DoNotationBind (h' b) (g' v)
80+ handleDoNotationElement (DoNotationLet ds) = DoNotationLet (map f' ds)
81+ handleDoNotationElement (PositionedDoNotationElement pos e) = PositionedDoNotationElement pos (handleDoNotationElement e)
82+
83+
84+everywhereOnValuesTopDownM :: (Functor m, Applicative m, Monad m) =>
85+ (Declaration -> m Declaration) ->
86+ (Expr -> m Expr) ->
87+ (Binder -> m Binder) ->
88+ (Declaration -> m Declaration, Expr -> m Expr, Binder -> m Binder)
89+everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h)
90+ where
91+ f' (DataBindingGroupDeclaration ds) = DataBindingGroupDeclaration <$> mapM (f' <=< f) ds
92+ f' (ValueDeclaration name nameKind bs val) = ValueDeclaration name nameKind <$> mapM (h' <=< h) bs <*> eitherM (mapM (pairM (g' <=< g) (g' <=< g))) (g' <=< g) val
93+ f' (BindingGroupDeclaration ds) = BindingGroupDeclaration <$> mapM (\(name, nameKind, val) -> (,,) name nameKind <$> (g val >>= g')) ds
94+ f' (TypeClassDeclaration name args implies ds) = TypeClassDeclaration name args implies <$> mapM (f' <=< f) ds
95+ f' (TypeInstanceDeclaration name cs className args ds) = TypeInstanceDeclaration name cs className args <$> mapM (f' <=< f) ds
96+ f' (PositionedDeclaration pos d) = PositionedDeclaration pos <$> (f d >>= f')
97+ f' other = f other
98+
99+ g' (UnaryMinus v) = UnaryMinus <$> (g v >>= g')
100+ g' (BinaryNoParens op v1 v2) = BinaryNoParens op <$> (g v1 >>= g') <*> (g v2 >>= g')
101+ g' (Parens v) = Parens <$> (g v >>= g')
102+ g' (ArrayLiteral vs) = ArrayLiteral <$> mapM (g' <=< g) vs
103+ g' (ObjectLiteral vs) = ObjectLiteral <$> mapM (sndM (g' <=< g)) vs
104+ g' (TypeClassDictionaryConstructorApp name v) = TypeClassDictionaryConstructorApp name <$> (g v >>= g')
105+ g' (Accessor prop v) = Accessor prop <$> (g v >>= g')
106+ g' (ObjectUpdate obj vs) = ObjectUpdate <$> (g obj >>= g') <*> mapM (sndM (g' <=< g)) vs
107+ g' (Abs name v) = Abs name <$> (g v >>= g')
108+ g' (App v1 v2) = App <$> (g v1 >>= g') <*> (g v2 >>= g')
109+ g' (IfThenElse v1 v2 v3) = IfThenElse <$> (g v1 >>= g') <*> (g v2 >>= g') <*> (g v3 >>= g')
110+ g' (Case vs alts) = Case <$> mapM (g' <=< g) vs <*> mapM handleCaseAlternative alts
111+ g' (TypedValue check v ty) = TypedValue check <$> (g v >>= g') <*> pure ty
112+ g' (Let ds v) = Let <$> mapM (f' <=< f) ds <*> (g v >>= g')
113+ g' (Do es) = Do <$> mapM handleDoNotationElement es
114+ g' (PositionedValue pos v) = PositionedValue pos <$> (g v >>= g')
115+ g' other = g other
116+
117+ h' (ConstructorBinder ctor bs) = ConstructorBinder ctor <$> mapM (h' <=< h) bs
118+ h' (ObjectBinder bs) = ObjectBinder <$> mapM (sndM (h' <=< h)) bs
119+ h' (ArrayBinder bs) = ArrayBinder <$> mapM (h' <=< h) bs
120+ h' (ConsBinder b1 b2) = ConsBinder <$> (h b1 >>= h') <*> (h b2 >>= h')
121+ h' (NamedBinder name b) = NamedBinder name <$> (h b >>= h')
122+ h' (PositionedBinder pos b) = PositionedBinder pos <$> (h b >>= h')
123+ h' other = h other
124+
125+ handleCaseAlternative (CaseAlternative bs val) = CaseAlternative <$> mapM (h' <=< h) bs
126+ <*> eitherM (mapM (pairM (g' <=< g) (g' <=< g))) (g' <=< g) val
127+
128+ handleDoNotationElement (DoNotationValue v) = DoNotationValue <$> (g' <=< g) v
129+ handleDoNotationElement (DoNotationBind b v) = DoNotationBind <$> (h' <=< h) b <*> (g' <=< g) v
130+ handleDoNotationElement (DoNotationLet ds) = DoNotationLet <$> mapM (f' <=< f) ds
131+ handleDoNotationElement (PositionedDoNotationElement pos e) = PositionedDoNotationElement pos <$> handleDoNotationElement e
132+
133+everywhereOnValuesM :: (Functor m, Applicative m, Monad m) =>
134+ (Declaration -> m Declaration) ->
135+ (Expr -> m Expr) ->
136+ (Binder -> m Binder) ->
137+ (Declaration -> m Declaration, Expr -> m Expr, Binder -> m Binder)
138+everywhereOnValuesM f g h = (f' <=< f, g' <=< g, h' <=< h)
139+ where
140+ f' (DataBindingGroupDeclaration ds) = (DataBindingGroupDeclaration <$> mapM f' ds) >>= f
141+ f' (ValueDeclaration name nameKind bs val) = (ValueDeclaration name nameKind <$> mapM h' bs <*> eitherM (mapM (pairM g' g')) g' val) >>= f
142+ f' (BindingGroupDeclaration ds) = (BindingGroupDeclaration <$> mapM (\(name, nameKind, val) -> (,,) name nameKind <$> g' val) ds) >>= f
143+ f' (TypeClassDeclaration name args implies ds) = (TypeClassDeclaration name args implies <$> mapM f' ds) >>= f
144+ f' (TypeInstanceDeclaration name cs className args ds) = (TypeInstanceDeclaration name cs className args <$> mapM f' ds) >>= f
145+ f' (PositionedDeclaration pos d) = (PositionedDeclaration pos <$> f' d) >>= f
146+ f' other = f other
147+
148+ g' (UnaryMinus v) = (UnaryMinus <$> g' v) >>= g
149+ g' (BinaryNoParens op v1 v2) = (BinaryNoParens op <$> g' v1 <*> g' v2) >>= g
150+ g' (Parens v) = (Parens <$> g' v) >>= g
151+ g' (ArrayLiteral vs) = (ArrayLiteral <$> mapM g' vs) >>= g
152+ g' (ObjectLiteral vs) = (ObjectLiteral <$> mapM (sndM g') vs) >>= g
153+ g' (TypeClassDictionaryConstructorApp name v) = (TypeClassDictionaryConstructorApp name <$> g' v) >>= g
154+ g' (Accessor prop v) = (Accessor prop <$> g' v) >>= g
155+ g' (ObjectUpdate obj vs) = (ObjectUpdate <$> g' obj <*> mapM (sndM g') vs) >>= g
156+ g' (Abs name v) = (Abs name <$> g' v) >>= g
157+ g' (App v1 v2) = (App <$> g' v1 <*> g' v2) >>= g
158+ g' (IfThenElse v1 v2 v3) = (IfThenElse <$> g' v1 <*> g' v2 <*> g' v3) >>= g
159+ g' (Case vs alts) = (Case <$> mapM g' vs <*> mapM handleCaseAlternative alts) >>= g
160+ g' (TypedValue check v ty) = (TypedValue check <$> g' v <*> pure ty) >>= g
161+ g' (Let ds v) = (Let <$> mapM f' ds <*> g' v) >>= g
162+ g' (Do es) = (Do <$> mapM handleDoNotationElement es) >>= g
163+ g' (PositionedValue pos v) = (PositionedValue pos <$> g' v) >>= g
164+ g' other = g other
165+
166+ h' (ConstructorBinder ctor bs) = (ConstructorBinder ctor <$> mapM h' bs) >>= h
167+ h' (ObjectBinder bs) = (ObjectBinder <$> mapM (sndM h') bs) >>= h
168+ h' (ArrayBinder bs) = (ArrayBinder <$> mapM h' bs) >>= h
169+ h' (ConsBinder b1 b2) = (ConsBinder <$> h' b1 <*> h' b2) >>= h
170+ h' (NamedBinder name b) = (NamedBinder name <$> h' b) >>= h
171+ h' (PositionedBinder pos b) = (PositionedBinder pos <$> h' b) >>= h
172+ h' other = h other
173+
174+ handleCaseAlternative (CaseAlternative bs val) = CaseAlternative <$> mapM h' bs
175+ <*> eitherM (mapM (pairM g' g')) g' val
176+
177+ handleDoNotationElement (DoNotationValue v) = DoNotationValue <$> g' v
178+ handleDoNotationElement (DoNotationBind b v) = DoNotationBind <$> h' b <*> g' v
179+ handleDoNotationElement (DoNotationLet ds) = DoNotationLet <$> mapM f' ds
180+ handleDoNotationElement (PositionedDoNotationElement pos e) = PositionedDoNotationElement pos <$> handleDoNotationElement e
181+
182+everythingOnValues :: (r -> r -> r) ->
183+ (Declaration -> r) ->
184+ (Expr -> r) ->
185+ (Binder -> r) ->
186+ (CaseAlternative -> r) ->
187+ (DoNotationElement -> r) ->
188+ (Declaration -> r, Expr -> r, Binder -> r, CaseAlternative -> r, DoNotationElement -> r)
189+everythingOnValues (<>) f g h i j = (f', g', h', i', j')
190+ where
191+ f' d@(DataBindingGroupDeclaration ds) = foldl (<>) (f d) (map f' ds)
192+ f' d@(ValueDeclaration _ _ bs (Right val)) = foldl (<>) (f d) (map h' bs) <> g' val
193+ f' d@(ValueDeclaration _ _ bs (Left gs)) = foldl (<>) (f d) (map h' bs ++ concatMap (\(grd, val) -> [g' grd, g' val]) gs)
194+ f' d@(BindingGroupDeclaration ds) = foldl (<>) (f d) (map (\(_, _, val) -> g' val) ds)
195+ f' d@(TypeClassDeclaration _ _ _ ds) = foldl (<>) (f d) (map f' ds)
196+ f' d@(TypeInstanceDeclaration _ _ _ _ ds) = foldl (<>) (f d) (map f' ds)
197+ f' d@(PositionedDeclaration _ d1) = f d <> f' d1
198+ f' d = f d
199+
200+ g' v@(UnaryMinus v1) = g v <> g' v1
201+ g' v@(BinaryNoParens _ v1 v2) = g v <> g' v1 <> g' v2
202+ g' v@(Parens v1) = g v <> g' v1
203+ g' v@(ArrayLiteral vs) = foldl (<>) (g v) (map g' vs)
204+ g' v@(ObjectLiteral vs) = foldl (<>) (g v) (map (g' . snd) vs)
205+ g' v@(TypeClassDictionaryConstructorApp _ v1) = g v <> g' v1
206+ g' v@(Accessor _ v1) = g v <> g' v1
207+ g' v@(ObjectUpdate obj vs) = foldl (<>) (g v <> g' obj) (map (g' . snd) vs)
208+ g' v@(Abs _ v1) = g v <> g' v1
209+ g' v@(App v1 v2) = g v <> g' v1 <> g' v2
210+ g' v@(IfThenElse v1 v2 v3) = g v <> g' v1 <> g' v2 <> g' v3
211+ g' v@(Case vs alts) = foldl (<>) (foldl (<>) (g v) (map g' vs)) (map i' alts)
212+ g' v@(TypedValue _ v1 _) = g v <> g' v1
213+ g' v@(Let ds v1) = foldl (<>) (g v) (map f' ds) <> g' v1
214+ g' v@(Do es) = foldl (<>) (g v) (map j' es)
215+ g' v@(PositionedValue _ v1) = g v <> g' v1
216+ g' v = g v
217+
218+ h' b@(ConstructorBinder _ bs) = foldl (<>) (h b) (map h' bs)
219+ h' b@(ObjectBinder bs) = foldl (<>) (h b) (map (h' . snd) bs)
220+ h' b@(ArrayBinder bs) = foldl (<>) (h b) (map h' bs)
221+ h' b@(ConsBinder b1 b2) = h b <> h' b1 <> h' b2
222+ h' b@(NamedBinder _ b1) = h b <> h' b1
223+ h' b@(PositionedBinder _ b1) = h b <> h' b1
224+ h' b = h b
225+
226+ i' ca@(CaseAlternative bs (Right val)) = foldl (<>) (i ca) (map h' bs) <> g' val
227+ i' ca@(CaseAlternative bs (Left gs)) = foldl (<>) (i ca) (map h' bs ++ concatMap (\(grd, val) -> [g' grd, g' val]) gs)
228+
229+ j' e@(DoNotationValue v) = j e <> g' v
230+ j' e@(DoNotationBind b v) = j e <> h' b <> g' v
231+ j' e@(DoNotationLet ds) = foldl (<>) (j e) (map f' ds)
232+ j' e@(PositionedDoNotationElement _ e1) = j e <> j' e1
233+
234+everythingWithContextOnValues ::
235+ s ->
236+ r ->
237+ (r -> r -> r) ->
238+ (s -> Declaration -> (s, r)) ->
239+ (s -> Expr -> (s, r)) ->
240+ (s -> Binder -> (s, r)) ->
241+ (s -> CaseAlternative -> (s, r)) ->
242+ (s -> DoNotationElement -> (s, r)) ->
243+ ( Declaration -> r
244+ , Expr -> r
245+ , Binder -> r
246+ , CaseAlternative -> r
247+ , DoNotationElement -> r)
248+everythingWithContextOnValues s0 r0 (<>) f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j'' s0)
249+ where
250+ f'' s d = let (s', r) = f s d in r <> f' s' d
251+
252+ f' s (DataBindingGroupDeclaration ds) = foldl (<>) r0 (map (f'' s) ds)
253+ f' s (ValueDeclaration _ _ bs (Right val)) = foldl (<>) r0 (map (h'' s) bs) <> g'' s val
254+ f' s (ValueDeclaration _ _ bs (Left gs)) = foldl (<>) r0 (map (h'' s) bs ++ concatMap (\(grd, val) -> [g'' s grd, g'' s val]) gs)
255+ f' s (BindingGroupDeclaration ds) = foldl (<>) r0 (map (\(_, _, val) -> g'' s val) ds)
256+ f' s (TypeClassDeclaration _ _ _ ds) = foldl (<>) r0 (map (f'' s) ds)
257+ f' s (TypeInstanceDeclaration _ _ _ _ ds) = foldl (<>) r0 (map (f'' s) ds)
258+ f' s (PositionedDeclaration _ d1) = f'' s d1
259+ f' _ _ = r0
260+
261+ g'' s v = let (s', r) = g s v in r <> g' s' v
262+
263+ g' s (UnaryMinus v1) = g'' s v1
264+ g' s (BinaryNoParens _ v1 v2) = g'' s v1 <> g'' s v2
265+ g' s (Parens v1) = g'' s v1
266+ g' s (ArrayLiteral vs) = foldl (<>) r0 (map (g'' s) vs)
267+ g' s (ObjectLiteral vs) = foldl (<>) r0 (map (g'' s . snd) vs)
268+ g' s (TypeClassDictionaryConstructorApp _ v1) = g'' s v1
269+ g' s (Accessor _ v1) = g'' s v1
270+ g' s (ObjectUpdate obj vs) = foldl (<>) (g'' s obj) (map (g'' s . snd) vs)
271+ g' s (Abs _ v1) = g'' s v1
272+ g' s (App v1 v2) = g'' s v1 <> g'' s v2
273+ g' s (IfThenElse v1 v2 v3) = g'' s v1 <> g'' s v2 <> g'' s v3
274+ g' s (Case vs alts) = foldl (<>) (foldl (<>) r0 (map (g'' s) vs)) (map (i'' s) alts)
275+ g' s (TypedValue _ v1 _) = g'' s v1
276+ g' s (Let ds v1) = foldl (<>) r0 (map (f'' s) ds) <> g'' s v1
277+ g' s (Do es) = foldl (<>) r0 (map (j'' s) es)
278+ g' s (PositionedValue _ v1) = g'' s v1
279+ g' _ _ = r0
280+
281+ h'' s b = let (s', r) = h s b in r <> h' s' b
282+
283+ h' s (ConstructorBinder _ bs) = foldl (<>) r0 (map (h'' s) bs)
284+ h' s (ObjectBinder bs) = foldl (<>) r0 (map (h'' s . snd) bs)
285+ h' s (ArrayBinder bs) = foldl (<>) r0 (map (h'' s) bs)
286+ h' s (ConsBinder b1 b2) = h'' s b1 <> h'' s b2
287+ h' s (NamedBinder _ b1) = h'' s b1
288+ h' s (PositionedBinder _ b1) = h'' s b1
289+ h' _ _ = r0
290+
291+ i'' s ca = let (s', r) = i s ca in r <> i' s' ca
292+
293+ i' s (CaseAlternative bs (Right val)) = foldl (<>) r0 (map (h'' s) bs) <> g'' s val
294+ i' s (CaseAlternative bs (Left gs)) = foldl (<>) r0 (map (h'' s) bs ++ concatMap (\(grd, val) -> [g'' s grd, g'' s val]) gs)
295+
296+ j'' s e = let (s', r) = j s e in r <> j' s' e
297+
298+ j' s (DoNotationValue v) = g'' s v
299+ j' s (DoNotationBind b v) = h'' s b <> g'' s v
300+ j' s (DoNotationLet ds) = foldl (<>) r0 (map (f'' s) ds)
301+ j' s (PositionedDoNotationElement _ e1) = j'' s e1
302+
303+everywhereWithContextOnValuesM :: (Functor m, Applicative m, Monad m) =>
304+ s ->
305+ (s -> Declaration -> m (s, Declaration)) ->
306+ (s -> Expr -> m (s, Expr)) ->
307+ (s -> Binder -> m (s, Binder)) ->
308+ (s -> CaseAlternative -> m (s, CaseAlternative)) ->
309+ (s -> DoNotationElement -> m (s, DoNotationElement)) ->
310+ ( Declaration -> m Declaration
311+ , Expr -> m Expr
312+ , Binder -> m Binder
313+ , CaseAlternative -> m CaseAlternative
314+ , DoNotationElement -> m DoNotationElement)
315+everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j'' s0)
316+ where
317+ f'' s = uncurry f' <=< f s
318+
319+ f' s (DataBindingGroupDeclaration ds) = DataBindingGroupDeclaration <$> mapM (f'' s) ds
320+ f' s (ValueDeclaration name nameKind bs val) = ValueDeclaration name nameKind <$> mapM (h'' s) bs <*> eitherM (mapM (pairM (g'' s) (g'' s))) (g'' s) val
321+ f' s (BindingGroupDeclaration ds) = BindingGroupDeclaration <$> mapM (thirdM (g'' s)) ds
322+ f' s (TypeClassDeclaration name args implies ds) = TypeClassDeclaration name args implies <$> mapM (f'' s) ds
323+ f' s (TypeInstanceDeclaration name cs className args ds) = TypeInstanceDeclaration name cs className args <$> mapM (f'' s) ds
324+ f' s (PositionedDeclaration pos d1) = PositionedDeclaration pos <$> f'' s d1
325+ f' _ other = return other
326+
327+ g'' s = uncurry g' <=< g s
328+
329+ g' s (UnaryMinus v) = UnaryMinus <$> g'' s v
330+ g' s (BinaryNoParens op v1 v2) = BinaryNoParens op <$> g'' s v1 <*> g'' s v2
331+ g' s (Parens v) = Parens <$> g'' s v
332+ g' s (ArrayLiteral vs) = ArrayLiteral <$> mapM (g'' s) vs
333+ g' s (ObjectLiteral vs) = ObjectLiteral <$> mapM (sndM (g'' s)) vs
334+ g' s (TypeClassDictionaryConstructorApp name v) = TypeClassDictionaryConstructorApp name <$> g'' s v
335+ g' s (Accessor prop v) = Accessor prop <$> g'' s v
336+ g' s (ObjectUpdate obj vs) = ObjectUpdate <$> g'' s obj <*> mapM (sndM (g'' s)) vs
337+ g' s (Abs name v) = Abs name <$> g'' s v
338+ g' s (App v1 v2) = App <$> g'' s v1 <*> g'' s v2
339+ g' s (IfThenElse v1 v2 v3) = IfThenElse <$> g'' s v1 <*> g'' s v2 <*> g'' s v3
340+ g' s (Case vs alts) = Case <$> mapM (g'' s) vs <*> mapM (i'' s) alts
341+ g' s (TypedValue check v ty) = TypedValue check <$> g'' s v <*> pure ty
342+ g' s (Let ds v) = Let <$> mapM (f'' s) ds <*> g'' s v
343+ g' s (Do es) = Do <$> mapM (j'' s) es
344+ g' s (PositionedValue pos v) = PositionedValue pos <$> g'' s v
345+ g' _ other = return other
346+
347+ h'' s = uncurry h' <=< h s
348+
349+ h' s (ConstructorBinder ctor bs) = ConstructorBinder ctor <$> mapM (h'' s) bs
350+ h' s (ObjectBinder bs) = ObjectBinder <$> mapM (sndM (h'' s)) bs
351+ h' s (ArrayBinder bs) = ArrayBinder <$> mapM (h'' s) bs
352+ h' s (ConsBinder b1 b2) = ConsBinder <$> h'' s b1 <*> h'' s b2
353+ h' s (NamedBinder name b) = NamedBinder name <$> h'' s b
354+ h' s (PositionedBinder pos b) = PositionedBinder pos <$> h'' s b
355+ h' _ other = return other
356+
357+ i'' s = uncurry i' <=< i s
358+
359+ i' s (CaseAlternative bs val) = CaseAlternative <$> mapM (h'' s) bs <*> eitherM (mapM (pairM (g'' s) (g'' s))) (g'' s) val
360+
361+ j'' s = uncurry j' <=< j s
362+
363+ j' s (DoNotationValue v) = DoNotationValue <$> g'' s v
364+ j' s (DoNotationBind b v) = DoNotationBind <$> h'' s b <*> g'' s v
365+ j' s (DoNotationLet ds) = DoNotationLet <$> mapM (f'' s) ds
366+ j' s (PositionedDoNotationElement pos e1) = PositionedDoNotationElement pos <$> j'' s e1
367+
368+accumTypes :: (Monoid r) => (Type -> r) -> (Declaration -> r, Expr -> r, Binder -> r, CaseAlternative -> r, DoNotationElement -> r)
369+accumTypes f = everythingOnValues mappend forDecls forValues (const mempty) (const mempty) (const mempty)
370+ where
371+ forDecls (DataDeclaration _ _ _ dctors) = mconcat (concatMap (map f . snd) dctors)
372+ forDecls (ExternDeclaration _ _ _ ty) = f ty
373+ forDecls (ExternInstanceDeclaration _ cs _ tys) = mconcat (concatMap (map f . snd) cs) `mappend` mconcat (map f tys)
374+ forDecls (TypeClassDeclaration _ _ implies _) = mconcat (concatMap (map f . snd) implies)
375+ forDecls (TypeInstanceDeclaration _ cs _ tys _) = mconcat (concatMap (map f . snd) cs) `mappend` mconcat (map f tys)
376+ forDecls (TypeSynonymDeclaration _ _ ty) = f ty
377+ forDecls (TypeDeclaration _ ty) = f ty
378+ forDecls _ = mempty
379+
380+ forValues (TypeClassDictionary _ (_, cs) _) = mconcat (map f cs)
381+ forValues (SuperClassDictionary _ tys) = mconcat (map f tys)
382+ forValues (TypedValue _ _ ty) = f ty
383+ forValues _ = mempty
src/Language/PureScript/CodeGen.hsnew file+25
@@ -0,0 +1,25 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.CodeGen
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- A collection of modules related to code generation:
13+--
14+-- [@Language.PureScript.CodeGen.JS@] Code generator for Javascript
15+--
16+-- [@Language.PureScript.CodeGen.Externs@] Code generator for extern (foreign import) files
17+--
18+-- [@Language.PureScript.CodeGen.Optimize@] Optimization passes for generated Javascript
19+--
20+-----------------------------------------------------------------------------
21+
22+module Language.PureScript.CodeGen (module C) where
23+
24+import Language.PureScript.CodeGen.JS as C
25+import Language.PureScript.CodeGen.Externs as C
src/Language/PureScript/CodeGen/Common.hsnew file+193
@@ -0,0 +1,193 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.CodeGen.Common
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- Common code generation utility functions
13+--
14+-----------------------------------------------------------------------------
15+
16+module Language.PureScript.CodeGen.Common where
17+
18+import Data.Char
19+import Data.List (intercalate)
20+import Data.Maybe (fromMaybe)
21+import Data.Function (on)
22+
23+import qualified Data.Map as M
24+
25+import Language.PureScript.Names
26+import Language.PureScript.Environment
27+import Language.PureScript.Types
28+
29+-- |
30+-- Convert an Ident into a valid Javascript identifier:
31+--
32+-- * Alphanumeric characters are kept unmodified.
33+--
34+-- * Reserved javascript identifiers are prefixed with '$$'.
35+--
36+-- * Symbols are prefixed with '$' followed by a symbol name or their ordinal value.
37+--
38+identToJs :: Ident -> String
39+identToJs (Ident name) | nameIsJsReserved name = "$$" ++ name
40+identToJs (Ident name) = concatMap identCharToString name
41+identToJs (Op op) = concatMap identCharToString op
42+
43+-- |
44+-- Test if a string is a valid JS identifier without escaping.
45+--
46+identNeedsEscaping :: String -> Bool
47+identNeedsEscaping s = s /= identToJs (Ident s)
48+
49+-- |
50+-- Attempts to find a human-readable name for a symbol, if none has been specified returns the
51+-- ordinal value.
52+--
53+identCharToString :: Char -> String
54+identCharToString c | isAlphaNum c = [c]
55+identCharToString '_' = "_"
56+identCharToString '.' = "$dot"
57+identCharToString '$' = "$dollar"
58+identCharToString '~' = "$tilde"
59+identCharToString '=' = "$eq"
60+identCharToString '<' = "$less"
61+identCharToString '>' = "$greater"
62+identCharToString '!' = "$bang"
63+identCharToString '#' = "$hash"
64+identCharToString '%' = "$percent"
65+identCharToString '^' = "$up"
66+identCharToString '&' = "$amp"
67+identCharToString '|' = "$bar"
68+identCharToString '*' = "$times"
69+identCharToString '/' = "$div"
70+identCharToString '+' = "$plus"
71+identCharToString '-' = "$minus"
72+identCharToString ':' = "$colon"
73+identCharToString '\\' = "$bslash"
74+identCharToString '?' = "$qmark"
75+identCharToString '@' = "$at"
76+identCharToString '\'' = "$prime"
77+identCharToString c = '$' : show (ord c)
78+
79+-- |
80+-- Checks whether an identifier name is reserved in Javascript.
81+--
82+nameIsJsReserved :: String -> Bool
83+nameIsJsReserved name =
84+ name `elem` [ "abstract"
85+ , "arguments"
86+ , "boolean"
87+ , "break"
88+ , "byte"
89+ , "case"
90+ , "catch"
91+ , "char"
92+ , "class"
93+ , "const"
94+ , "continue"
95+ , "debugger"
96+ , "default"
97+ , "delete"
98+ , "do"
99+ , "double"
100+ , "else"
101+ , "enum"
102+ , "eval"
103+ , "export"
104+ , "extends"
105+ , "final"
106+ , "finally"
107+ , "float"
108+ , "for"
109+ , "function"
110+ , "goto"
111+ , "if"
112+ , "implements"
113+ , "import"
114+ , "in"
115+ , "instanceof"
116+ , "int"
117+ , "interface"
118+ , "let"
119+ , "long"
120+ , "native"
121+ , "new"
122+ , "null"
123+ , "package"
124+ , "private"
125+ , "protected"
126+ , "public"
127+ , "return"
128+ , "short"
129+ , "static"
130+ , "super"
131+ , "switch"
132+ , "synchronized"
133+ , "this"
134+ , "throw"
135+ , "throws"
136+ , "transient"
137+ , "try"
138+ , "typeof"
139+ , "var"
140+ , "void"
141+ , "volatile"
142+ , "while"
143+ , "with"
144+ , "yield" ]
145+
146+moduleNameToJs :: ModuleName -> String
147+moduleNameToJs (ModuleName pns) = intercalate "_" (runProperName `map` pns)
148+
149+-- |
150+-- Finds the value stored for a data constructor in the current environment.
151+-- This is a partial function, but if an invalid type has reached this far then
152+-- something has gone wrong in typechecking.
153+--
154+lookupConstructor :: Environment -> Qualified ProperName -> (DataDeclType, ProperName, Type)
155+lookupConstructor e ctor = fromMaybe (error "Data constructor not found") $ ctor `M.lookup` dataConstructors e
156+
157+-- |
158+-- Checks whether a data constructor is the only constructor for that type, used
159+-- to simplify the check when generating code for binders.
160+--
161+isOnlyConstructor :: Environment -> Qualified ProperName -> Bool
162+isOnlyConstructor e ctor = numConstructors (ctor, lookupConstructor e ctor) == 1
163+ where
164+ numConstructors :: (Qualified ProperName, (DataDeclType, ProperName, Type)) -> Int
165+ numConstructors ty = length $ filter (((==) `on` typeConstructor) ty) $ M.toList $ dataConstructors e
166+ typeConstructor :: (Qualified ProperName, (DataDeclType, ProperName, Type)) -> (ModuleName, ProperName)
167+ typeConstructor (Qualified (Just moduleName) _, (_, tyCtor, _)) = (moduleName, tyCtor)
168+ typeConstructor _ = error "Invalid argument to isOnlyConstructor"
169+
170+-- |
171+-- Checks whether a data constructor is for a newtype.
172+--
173+isNewtypeConstructor :: Environment -> Qualified ProperName -> Bool
174+isNewtypeConstructor e ctor = case lookupConstructor e ctor of
175+ (Newtype, _, _) -> True
176+ (Data, _, _) -> False
177+
178+-- |
179+-- Checks the number of arguments a data constructor accepts.
180+--
181+getConstructorArity :: Environment -> Qualified ProperName -> Int
182+getConstructorArity e = go . (\(_, _, ctors) -> ctors) . lookupConstructor e
183+ where
184+ go :: Type -> Int
185+ go (TypeApp (TypeApp f _) t) | f == tyFunction = go t + 1
186+ go (ForAll _ ty _) = go ty
187+ go _ = 0
188+
189+-- |
190+-- Checks whether a data constructor has no arguments, for example, `Nothing`.
191+--
192+isNullaryConstructor :: Environment -> Qualified ProperName -> Bool
193+isNullaryConstructor e = (== 0) . getConstructorArity e
src/Language/PureScript/CodeGen/Externs.hsnew file+112
@@ -0,0 +1,112 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.CodeGen.Externs
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- This module generates code for \"externs\" files, i.e. files containing only foreign import declarations.
13+--
14+-----------------------------------------------------------------------------
15+
16+module Language.PureScript.CodeGen.Externs (
17+ moduleToPs
18+) where
19+
20+import Data.Maybe (fromMaybe, mapMaybe)
21+import Data.List (intercalate, find)
22+
23+import qualified Data.Map as M
24+
25+import Control.Monad.Writer
26+
27+import Language.PureScript.CodeGen.Common
28+import Language.PureScript.TypeClassDictionaries
29+import Language.PureScript.AST
30+import Language.PureScript.Pretty
31+import Language.PureScript.Names
32+import Language.PureScript.Kinds
33+import Language.PureScript.Types
34+import Language.PureScript.Environment
35+
36+-- |
37+-- Generate foreign imports for all declarations in a module
38+--
39+moduleToPs :: Module -> Environment -> String
40+moduleToPs (Module _ _ Nothing) _ = error "Module exports were not elaborated in moduleToPs"
41+moduleToPs (Module moduleName ds (Just exts)) env = intercalate "\n" . execWriter $ do
42+ tell [ "module " ++ runModuleName moduleName ++ " where"]
43+ mapM_ declToPs ds
44+ mapM_ exportToPs exts
45+ where
46+
47+ declToPs :: Declaration -> Writer [String] ()
48+ declToPs (ImportDeclaration mn _ _) = tell ["import " ++ show mn ++ " ()"]
49+ declToPs (FixityDeclaration (Fixity assoc prec) ident) =
50+ tell [ unwords [ show assoc, show prec, ident ] ]
51+ declToPs (PositionedDeclaration _ d) = declToPs d
52+ declToPs _ = return ()
53+
54+ exportToPs :: DeclarationRef -> Writer [String] ()
55+ exportToPs (PositionedDeclarationRef _ r) = exportToPs r
56+ exportToPs (TypeRef pn dctors) = do
57+ case Qualified (Just moduleName) pn `M.lookup` types env of
58+ Nothing -> error $ show pn ++ " has no kind in exportToPs"
59+ Just (kind, ExternData) ->
60+ tell ["foreign import data " ++ show pn ++ " :: " ++ prettyPrintKind kind]
61+ Just (_, DataType args tys) -> do
62+ let dctors' = fromMaybe (map fst tys) dctors
63+ printDctor dctor = case dctor `lookup` tys of
64+ Nothing -> Nothing
65+ Just tyArgs -> Just $ show dctor ++ " " ++ unwords (map prettyPrintTypeAtom tyArgs)
66+ let dtype = if length dctors' == 1 && isNewtypeConstructor env (Qualified (Just moduleName) $ head dctors')
67+ then "newtype"
68+ else "data"
69+ typeName = prettyPrintType $ foldl TypeApp (TypeConstructor (Qualified Nothing pn)) (map toTypeVar args)
70+ tell [dtype ++ " " ++ typeName ++ (if null dctors' then "" else " = " ++ intercalate " | " (mapMaybe printDctor dctors'))]
71+ Just (_, TypeSynonym) ->
72+ case Qualified (Just moduleName) pn `M.lookup` typeSynonyms env of
73+ Nothing -> error $ show pn ++ " has no type synonym info in exportToPs"
74+ Just (args, synTy) ->
75+ let
76+ typeName = prettyPrintType $ foldl TypeApp (TypeConstructor (Qualified Nothing pn)) (map toTypeVar args)
77+ in tell ["type " ++ typeName ++ " = " ++ prettyPrintType synTy]
78+ _ -> error "Invalid input in exportToPs"
79+
80+ exportToPs (ValueRef ident) =
81+ case (moduleName, ident) `M.lookup` names env of
82+ Nothing -> error $ show ident ++ " has no type in exportToPs"
83+ Just (ty, nameKind, _) | nameKind == Value || nameKind == Extern ForeignImport || nameKind == Extern InlineJavascript ->
84+ tell ["foreign import " ++ show ident ++ " :: " ++ prettyPrintType ty]
85+ _ -> return ()
86+ exportToPs (TypeClassRef className) =
87+ case Qualified (Just moduleName) className `M.lookup` typeClasses env of
88+ Nothing -> error $ show className ++ " has no type class definition in exportToPs"
89+ Just (args, members, implies) -> do
90+ let impliesString = if null implies
91+ then ""
92+ else "(" ++ intercalate ", " (map (\(pn, tys') -> show pn ++ " " ++ unwords (map prettyPrintTypeAtom tys')) implies) ++ ") <= "
93+ typeName = prettyPrintType $ foldl TypeApp (TypeConstructor (Qualified Nothing className)) (map toTypeVar args)
94+ tell ["class " ++ impliesString ++ typeName ++ " where"]
95+ forM_ (filter (isValueExported . fst) members) $ \(member ,ty) ->
96+ tell [ " " ++ show member ++ " :: " ++ prettyPrintType ty ]
97+
98+ exportToPs (TypeInstanceRef ident) = do
99+ let TypeClassDictionaryInScope { tcdClassName = className, tcdInstanceTypes = tys, tcdDependencies = deps} =
100+ fromMaybe (error $ "Type class instance has no dictionary in exportToPs") . find ((== Qualified (Just moduleName) ident) . tcdName) $ M.elems $ typeClassDictionaries env
101+ let constraintsText = case fromMaybe [] deps of
102+ [] -> ""
103+ cs -> "(" ++ intercalate ", " (map (\(pn, tys') -> show pn ++ " " ++ unwords (map prettyPrintTypeAtom tys')) cs) ++ ") => "
104+ tell ["foreign import instance " ++ show ident ++ " :: " ++ constraintsText ++ show className ++ " " ++ unwords (map prettyPrintTypeAtom tys)]
105+
106+ toTypeVar :: (String, Maybe Kind) -> Type
107+ toTypeVar (s, Nothing) = TypeVar s
108+ toTypeVar (s, Just k) = KindedType (TypeVar s) k
109+
110+ isValueExported :: Ident -> Bool
111+ isValueExported ident = ValueRef ident `elem` exts
112+
src/Language/PureScript/CodeGen/JS.hsnew file+384
@@ -0,0 +1,384 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.CodeGen.JS
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- This module generates code in the simplified Javascript intermediate representation from Purescript code
13+--
14+-----------------------------------------------------------------------------
15+
16+{-# LANGUAGE GADTs, DoAndIfThenElse #-}
17+
18+module Language.PureScript.CodeGen.JS (
19+ module AST,
20+ declToJs,
21+ moduleToJs,
22+ identNeedsEscaping
23+) where
24+
25+import Data.Maybe (catMaybes)
26+import Data.Function (on)
27+import Data.List (nub, (\\), delete, sortBy)
28+
29+import qualified Data.Map as M
30+
31+import Control.Monad (foldM, replicateM, forM)
32+import Control.Applicative
33+import Control.Arrow (second)
34+
35+import Language.PureScript.Names
36+import Language.PureScript.AST
37+import Language.PureScript.Options
38+import Language.PureScript.CodeGen.JS.AST as AST
39+import Language.PureScript.Optimizer
40+import Language.PureScript.CodeGen.Common
41+import Language.PureScript.Environment
42+import Language.PureScript.Supply
43+import Language.PureScript.Traversals (sndM)
44+import qualified Language.PureScript.Constants as C
45+
46+-- |
47+-- Generate code in the simplified Javascript intermediate representation for all declarations in a
48+-- module.
49+--
50+moduleToJs :: (Functor m, Applicative m, Monad m) => Options mode -> Module -> Environment -> SupplyT m [JS]
51+moduleToJs opts (Module name decls (Just exps)) env = do
52+ let jsImports = map (importToJs opts) . delete (ModuleName [ProperName C.prim]) . (\\ [name]) . nub $ concatMap imports decls
53+ jsDecls <- mapM (\decl -> declToJs opts name decl env) decls
54+ let optimized = concat $ map (map $ optimize opts) $ catMaybes jsDecls
55+ let isModuleEmpty = null exps
56+ let moduleBody = JSStringLiteral "use strict" : jsImports ++ optimized
57+ let moduleExports = JSObjectLiteral . map (second var) . M.toList . M.unions $ map exportToJs exps
58+ return $ case optionsAdditional opts of
59+ MakeOptions -> moduleBody ++ [JSAssignment (JSAccessor "exports" (JSVar "module")) moduleExports]
60+ CompileOptions ns _ _ | not isModuleEmpty ->
61+ [ JSVariableIntroduction ns
62+ (Just (JSBinary Or (JSVar ns) (JSObjectLiteral [])) )
63+ , JSAssignment (JSAccessor (moduleNameToJs name) (JSVar ns))
64+ (JSApp (JSFunction Nothing [] (JSBlock (moduleBody ++ [JSReturn moduleExports]))) [])
65+ ]
66+ _ -> []
67+moduleToJs _ _ _ = error "Exports should have been elaborated in name desugaring"
68+
69+importToJs :: Options mode -> ModuleName -> JS
70+importToJs opts mn =
71+ JSVariableIntroduction (moduleNameToJs mn) (Just moduleBody)
72+ where
73+ moduleBody = case optionsAdditional opts of
74+ MakeOptions -> JSApp (JSVar "require") [JSStringLiteral (runModuleName mn)]
75+ CompileOptions ns _ _ -> JSAccessor (moduleNameToJs mn) (JSVar ns)
76+
77+imports :: Declaration -> [ModuleName]
78+imports (ImportDeclaration mn _ _) = [mn]
79+imports other =
80+ let (f, _, _, _, _) = everythingOnValues (++) (const []) collectV collectB (const []) (const [])
81+ in f other
82+ where
83+ collectV :: Expr -> [ModuleName]
84+ collectV (Var (Qualified (Just mn) _)) = [mn]
85+ collectV (Constructor (Qualified (Just mn) _)) = [mn]
86+ collectV (TypeClassDictionaryConstructorApp (Qualified (Just mn) _) _) = [mn]
87+ collectV _ = []
88+ collectB :: Binder -> [ModuleName]
89+ collectB (ConstructorBinder (Qualified (Just mn) _) _) = [mn]
90+ collectB _ = []
91+
92+-- |
93+-- Generate code in the simplified Javascript intermediate representation for a declaration
94+--
95+declToJs :: (Functor m, Applicative m, Monad m) => Options mode -> ModuleName -> Declaration -> Environment -> SupplyT m (Maybe [JS])
96+declToJs opts mp (ValueDeclaration ident _ _ (Right val)) e = do
97+ js <- valueToJs opts mp e val
98+ return $ Just [JSVariableIntroduction (identToJs ident) (Just js)]
99+declToJs opts mp (BindingGroupDeclaration vals) e = do
100+ jss <- forM vals $ \(ident, _, val) -> do
101+ js <- valueToJs opts mp e val
102+ return $ JSVariableIntroduction (identToJs ident) (Just js)
103+ return $ Just jss
104+declToJs _ _ (DataDeclaration Newtype _ _ [((ProperName ctor), _)]) _ =
105+ return $ Just $ [JSVariableIntroduction ctor (Just $
106+ JSObjectLiteral [("create",
107+ JSFunction Nothing ["value"]
108+ (JSBlock [JSReturn $ JSVar "value"]))])]
109+declToJs _ _ (DataDeclaration Newtype _ _ _) _ =
110+ error "newtype has multiple constructors"
111+declToJs _ mp (DataDeclaration Data _ _ ctors) e = do
112+ return $ Just $ flip concatMap ctors $ \(pn@(ProperName ctor), tys) ->
113+ let propName = if isNullaryConstructor e (Qualified (Just mp) pn) then "value" else "create"
114+ in [ makeConstructor ctor (length tys)
115+ , JSAssignment (JSAccessor propName (JSVar ctor)) (go pn 0 (length tys) [])
116+ ]
117+ where
118+ makeConstructor :: String -> Int -> JS
119+ makeConstructor ctorName n =
120+ let
121+ args = [ "value" ++ show index | index <- [0..n-1] ]
122+ body = [ JSAssignment (JSAccessor arg (JSVar "this")) (JSVar arg) | arg <- args ]
123+ in JSFunction (Just ctorName) args (JSBlock body)
124+ go :: ProperName -> Int -> Int -> [JS] -> JS
125+ go pn _ 0 values = JSUnary JSNew $ JSApp (JSVar $ runProperName pn) (reverse values)
126+ go pn index n values =
127+ JSFunction Nothing ["value" ++ show index]
128+ (JSBlock [JSReturn (go pn (index + 1) (n - 1) (JSVar ("value" ++ show index) : values))])
129+declToJs opts mp (DataBindingGroupDeclaration ds) e = do
130+ jss <- mapM (\decl -> declToJs opts mp decl e) ds
131+ return $ Just $ concat $ catMaybes jss
132+declToJs _ _ (TypeClassDeclaration name _ supers members) _ =
133+ return $ Just $ [
134+ JSFunction (Just $ runProperName name) (identToJs `map` args)
135+ (JSBlock $ assn `map` args)]
136+ where
137+ assn :: Ident -> JS
138+ assn arg = JSAssignment (accessor arg (JSVar "this")) (var arg)
139+ args :: [Ident]
140+ args = sortBy (compare `on` runIdent) $ memberNames ++ superNames
141+ memberNames :: [Ident]
142+ memberNames = memberToName `map` members
143+ superNames :: [Ident]
144+ superNames = [ toSuperName superclass index
145+ | (index, (superclass, _)) <- zip [0..] supers
146+ ]
147+ toSuperName :: Qualified ProperName -> Integer -> Ident
148+ toSuperName pn index = Ident $ C.__superclass_ ++ show pn ++ "_" ++ show index
149+ memberToName :: Declaration -> Ident
150+ memberToName (TypeDeclaration ident _) = ident
151+ memberToName (PositionedDeclaration _ d) = memberToName d
152+ memberToName _ = error "Invalid declaration in type class definition"
153+declToJs _ _ (ExternDeclaration _ _ (Just js) _) _ = return $ Just [js]
154+declToJs opts mp (PositionedDeclaration _ d) e = declToJs opts mp d e
155+declToJs _ _ _ _ = return Nothing
156+
157+-- |
158+-- Generate key//value pairs for an object literal exporting values from a module.
159+--
160+exportToJs :: DeclarationRef -> M.Map String Ident
161+exportToJs (TypeRef _ (Just dctors)) = M.fromList [ (n, Ident n) | (ProperName n) <- dctors ]
162+exportToJs (ValueRef name) = M.singleton (runIdent name) name
163+exportToJs (TypeInstanceRef name) = M.singleton (runIdent name) name
164+exportToJs (TypeClassRef name) = M.singleton (runProperName name) (Ident $ runProperName name)
165+exportToJs _ = M.empty
166+
167+-- |
168+-- Generate code in the simplified Javascript intermediate representation for a variable based on a
169+-- PureScript identifier.
170+--
171+var :: Ident -> JS
172+var = JSVar . identToJs
173+
174+-- |
175+-- Generate code in the simplified Javascript intermediate representation for an accessor based on
176+-- a PureScript identifier. If the name is not valid in Javascript (symbol based, reserved name) an
177+-- indexer is returned.
178+--
179+accessor :: Ident -> JS -> JS
180+accessor (Ident prop) = accessorString prop
181+accessor (Op op) = JSIndexer (JSStringLiteral op)
182+
183+accessorString :: String -> JS -> JS
184+accessorString prop | identNeedsEscaping prop = JSIndexer (JSStringLiteral prop)
185+ | otherwise = JSAccessor prop
186+
187+-- |
188+-- Generate code in the simplified Javascript intermediate representation for a value or expression.
189+--
190+valueToJs :: (Functor m, Applicative m, Monad m) => Options mode -> ModuleName -> Environment -> Expr -> SupplyT m JS
191+valueToJs _ _ _ (NumericLiteral n) = return $ JSNumericLiteral n
192+valueToJs _ _ _ (StringLiteral s) = return $ JSStringLiteral s
193+valueToJs _ _ _ (BooleanLiteral b) = return $ JSBooleanLiteral b
194+valueToJs opts m e (ArrayLiteral xs) = JSArrayLiteral <$> mapM (valueToJs opts m e) xs
195+valueToJs opts m e (ObjectLiteral ps) = JSObjectLiteral <$> mapM (sndM (valueToJs opts m e)) ps
196+valueToJs opts m e (TypeClassDictionaryConstructorApp name (TypedValue _ (ObjectLiteral ps) _)) =
197+ JSUnary JSNew . JSApp (qualifiedToJS m (Ident . runProperName) name) <$> mapM (valueToJs opts m e . snd) (sortBy (compare `on` fst) ps)
198+valueToJs _ _ _ TypeClassDictionaryConstructorApp{} =
199+ error "TypeClassDictionaryConstructorApp did not contain object literal"
200+valueToJs opts m e (ObjectUpdate o ps) = do
201+ obj <- valueToJs opts m e o
202+ sts <- mapM (sndM (valueToJs opts m e)) ps
203+ extendObj obj sts
204+valueToJs _ m e (Constructor name) =
205+ let propName = if isNullaryConstructor e name then "value" else "create"
206+ in return $ JSAccessor propName $ qualifiedToJS m (Ident . runProperName) name
207+valueToJs opts m e (Case values binders) = do
208+ vals <- mapM (valueToJs opts m e) values
209+ bindersToJs opts m e binders vals
210+valueToJs opts m e (IfThenElse cond th el) = JSConditional <$> valueToJs opts m e cond <*> valueToJs opts m e th <*> valueToJs opts m e el
211+valueToJs opts m e (Accessor prop val) = accessorString prop <$> valueToJs opts m e val
212+valueToJs opts m e v@App{} = do
213+ let (f, args) = unApp v []
214+ args' <- mapM (valueToJs opts m e) args
215+ case f of
216+ Constructor name | isNewtypeConstructor e name && length args == 1 -> return (head args')
217+ Constructor name | getConstructorArity e name == length args ->
218+ return $ JSUnary JSNew $ JSApp (qualifiedToJS m (Ident . runProperName) name) args'
219+ _ -> flip (foldl (\fn a -> JSApp fn [a])) args' <$> valueToJs opts m e f
220+ where
221+ unApp :: Expr -> [Expr] -> (Expr, [Expr])
222+ unApp (App val arg) args = unApp val (arg : args)
223+ unApp (PositionedValue _ val) args = unApp val args
224+ unApp (TypedValue _ val _) args = unApp val args
225+ unApp other args = (other, args)
226+valueToJs opts m e (Let ds val) = do
227+ decls <- concat . catMaybes <$> mapM (flip (declToJs opts m) e) ds
228+ ret <- valueToJs opts m e val
229+ return $ JSApp (JSFunction Nothing [] (JSBlock (decls ++ [JSReturn ret]))) []
230+valueToJs opts m e (Abs (Left arg) val) = do
231+ ret <- valueToJs opts m e val
232+ return $ JSFunction Nothing [identToJs arg] (JSBlock [JSReturn ret])
233+valueToJs _ m _ (Var ident) = return $ varToJs m ident
234+valueToJs opts m e (TypedValue _ val _) = valueToJs opts m e val
235+valueToJs opts m e (PositionedValue _ val) = valueToJs opts m e val
236+valueToJs _ _ _ (TypeClassDictionary _ _ _) = error "Type class dictionary was not replaced"
237+valueToJs _ _ _ _ = error "Invalid argument to valueToJs"
238+
239+-- |
240+-- Shallow copy an object.
241+--
242+extendObj :: (Functor m, Applicative m, Monad m) => JS -> [(String, JS)] -> SupplyT m JS
243+extendObj obj sts = do
244+ newObj <- freshName
245+ key <- freshName
246+ let
247+ jsKey = JSVar key
248+ jsNewObj = JSVar newObj
249+ block = JSBlock (objAssign:copy:extend ++ [JSReturn jsNewObj])
250+ objAssign = JSVariableIntroduction newObj (Just $ JSObjectLiteral [])
251+ copy = JSForIn key obj $ JSBlock [JSIfElse cond assign Nothing]
252+ cond = JSApp (JSAccessor "hasOwnProperty" obj) [jsKey]
253+ assign = JSBlock [JSAssignment (JSIndexer jsKey jsNewObj) (JSIndexer jsKey obj)]
254+ stToAssign (s, js) = JSAssignment (JSAccessor s jsNewObj) js
255+ extend = map stToAssign sts
256+ return $ JSApp (JSFunction Nothing [] block) []
257+
258+-- |
259+-- Generate code in the simplified Javascript intermediate representation for a reference to a
260+-- variable.
261+--
262+varToJs :: ModuleName -> Qualified Ident -> JS
263+varToJs _ (Qualified Nothing ident) = var ident
264+varToJs m qual = qualifiedToJS m id qual
265+
266+-- |
267+-- Generate code in the simplified Javascript intermediate representation for a reference to a
268+-- variable that may have a qualified name.
269+--
270+qualifiedToJS :: ModuleName -> (a -> Ident) -> Qualified a -> JS
271+qualifiedToJS _ f (Qualified (Just (ModuleName [ProperName mn])) a) | mn == C.prim = JSVar . runIdent $ f a
272+qualifiedToJS m f (Qualified (Just m') a) | m /= m' = accessor (f a) (JSVar (moduleNameToJs m'))
273+qualifiedToJS _ f (Qualified _ a) = JSVar $ identToJs (f a)
274+
275+-- |
276+-- Generate code in the simplified Javascript intermediate representation for pattern match binders
277+-- and guards.
278+--
279+bindersToJs :: (Functor m, Applicative m, Monad m) => Options mode -> ModuleName -> Environment -> [CaseAlternative] -> [JS] -> SupplyT m JS
280+bindersToJs opts m e binders vals = do
281+ valNames <- replicateM (length vals) freshName
282+ let assignments = zipWith JSVariableIntroduction valNames (map Just vals)
283+ jss <- forM binders $ \(CaseAlternative bs result) -> do
284+ ret <- guardsToJs result
285+ go valNames ret bs
286+ return $ JSApp (JSFunction Nothing [] (JSBlock (assignments ++ concat jss ++ [JSThrow $ JSUnary JSNew $ JSApp (JSVar "Error") $ [JSStringLiteral "Failed pattern match"]])))
287+ []
288+ where
289+ go :: (Functor m, Applicative m, Monad m) => [String] -> [JS] -> [Binder] -> SupplyT m [JS]
290+ go _ done [] = return done
291+ go (v:vs) done' (b:bs) = do
292+ done'' <- go vs done' bs
293+ binderToJs m e v done'' b
294+ go _ _ _ = error "Invalid arguments to bindersToJs"
295+
296+ guardsToJs :: (Functor m, Applicative m, Monad m) => Either [(Guard, Expr)] Expr -> SupplyT m [JS]
297+ guardsToJs (Left gs) = forM gs $ \(cond, val) -> do
298+ cond' <- valueToJs opts m e cond
299+ done <- valueToJs opts m e val
300+ return $ JSIfElse cond' (JSBlock [JSReturn done]) Nothing
301+ guardsToJs (Right v) = return . JSReturn <$> valueToJs opts m e v
302+
303+-- |
304+-- Generate code in the simplified Javascript intermediate representation for a pattern match
305+-- binder.
306+--
307+binderToJs :: (Functor m, Applicative m, Monad m) => ModuleName -> Environment -> String -> [JS] -> Binder -> SupplyT m [JS]
308+binderToJs _ _ _ done NullBinder = return done
309+binderToJs _ _ varName done (StringBinder str) =
310+ return [JSIfElse (JSBinary EqualTo (JSVar varName) (JSStringLiteral str)) (JSBlock done) Nothing]
311+binderToJs _ _ varName done (NumberBinder num) =
312+ return [JSIfElse (JSBinary EqualTo (JSVar varName) (JSNumericLiteral num)) (JSBlock done) Nothing]
313+binderToJs _ _ varName done (BooleanBinder True) =
314+ return [JSIfElse (JSVar varName) (JSBlock done) Nothing]
315+binderToJs _ _ varName done (BooleanBinder False) =
316+ return [JSIfElse (JSUnary Not (JSVar varName)) (JSBlock done) Nothing]
317+binderToJs _ _ varName done (VarBinder ident) =
318+ return (JSVariableIntroduction (identToJs ident) (Just (JSVar varName)) : done)
319+binderToJs m e varName done (ConstructorBinder ctor bs) | isNewtypeConstructor e ctor =
320+ case bs of
321+ [b] -> binderToJs m e varName done b
322+ _ -> error "binder for newtype constructor should have a single argument"
323+binderToJs m e varName done (ConstructorBinder ctor bs) = do
324+ js <- go 0 done bs
325+ if isOnlyConstructor e ctor
326+ then
327+ return js
328+ else
329+ return [JSIfElse (JSInstanceOf (JSVar varName) (qualifiedToJS m (Ident . runProperName) ctor))
330+ (JSBlock js)
331+ Nothing]
332+ where
333+ go :: (Functor m, Applicative m, Monad m) => Integer -> [JS] -> [Binder] -> SupplyT m [JS]
334+ go _ done' [] = return done'
335+ go index done' (binder:bs') = do
336+ argVar <- freshName
337+ done'' <- go (index + 1) done' bs'
338+ js <- binderToJs m e argVar done'' binder
339+ return (JSVariableIntroduction argVar (Just (JSAccessor ("value" ++ show index) (JSVar varName))) : js)
340+binderToJs m e varName done (ObjectBinder bs) = go done bs
341+ where
342+ go :: (Functor m, Applicative m, Monad m) => [JS] -> [(String, Binder)] -> SupplyT m [JS]
343+ go done' [] = return done'
344+ go done' ((prop, binder):bs') = do
345+ propVar <- freshName
346+ done'' <- go done' bs'
347+ js <- binderToJs m e propVar done'' binder
348+ return (JSVariableIntroduction propVar (Just (accessorString prop (JSVar varName))) : js)
349+binderToJs m e varName done (ArrayBinder bs) = do
350+ js <- go done 0 bs
351+ return [JSIfElse (JSBinary EqualTo (JSAccessor "length" (JSVar varName)) (JSNumericLiteral (Left (fromIntegral $ length bs)))) (JSBlock js) Nothing]
352+ where
353+ go :: (Functor m, Applicative m, Monad m) => [JS] -> Integer -> [Binder] -> SupplyT m [JS]
354+ go done' _ [] = return done'
355+ go done' index (binder:bs') = do
356+ elVar <- freshName
357+ done'' <- go done' (index + 1) bs'
358+ js <- binderToJs m e elVar done'' binder
359+ return (JSVariableIntroduction elVar (Just (JSIndexer (JSNumericLiteral (Left index)) (JSVar varName))) : js)
360+binderToJs m e varName done binder@(ConsBinder _ _) = do
361+ let (headBinders, tailBinder) = uncons [] binder
362+ numberOfHeadBinders = fromIntegral $ length headBinders
363+ js1 <- foldM (\done' (headBinder, index) -> do
364+ headVar <- freshName
365+ jss <- binderToJs m e headVar done' headBinder
366+ return (JSVariableIntroduction headVar (Just (JSIndexer (JSNumericLiteral (Left index)) (JSVar varName))) : jss)) done (zip headBinders [0..])
367+ tailVar <- freshName
368+ js2 <- binderToJs m e tailVar js1 tailBinder
369+ return [JSIfElse (JSBinary GreaterThanOrEqualTo (JSAccessor "length" (JSVar varName)) (JSNumericLiteral (Left numberOfHeadBinders))) (JSBlock
370+ ( JSVariableIntroduction tailVar (Just (JSApp (JSAccessor "slice" (JSVar varName)) [JSNumericLiteral (Left numberOfHeadBinders)])) :
371+ js2
372+ )) Nothing]
373+ where
374+ uncons :: [Binder] -> Binder -> ([Binder], Binder)
375+ uncons acc (ConsBinder h t) = uncons (h : acc) t
376+ uncons acc (PositionedBinder _ b) = uncons acc b
377+ uncons acc tailBinder = (reverse acc, tailBinder)
378+binderToJs m e varName done (NamedBinder ident binder) = do
379+ js <- binderToJs m e varName done binder
380+ return (JSVariableIntroduction (identToJs ident) (Just (JSVar varName)) : js)
381+binderToJs m e varName done (PositionedBinder _ binder) =
382+ binderToJs m e varName done binder
383+
384+
src/Language/PureScript/CodeGen/JS/AST.hsnew file+328
@@ -0,0 +1,328 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.CodeGen.JS.AST
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- Data types for the intermediate simplified-Javascript AST
13+--
14+-----------------------------------------------------------------------------
15+
16+{-# LANGUAGE DeriveDataTypeable #-}
17+
18+module Language.PureScript.CodeGen.JS.AST where
19+
20+import Data.Data
21+
22+-- |
23+-- Built-in unary operators
24+--
25+data UnaryOperator
26+ -- |
27+ -- Numeric negation
28+ --
29+ = Negate
30+ -- |
31+ -- Boolean negation
32+ --
33+ | Not
34+ -- |
35+ -- Bitwise negation
36+ --
37+ | BitwiseNot
38+ -- |
39+ -- Numeric unary \'plus\'
40+ --
41+ | Positive
42+ -- |
43+ -- Constructor
44+ --
45+ | JSNew deriving (Show, Eq, Data, Typeable)
46+
47+-- |
48+-- Built-in binary operators
49+--
50+data BinaryOperator
51+ -- |
52+ -- Numeric addition
53+ --
54+ = Add
55+ -- |
56+ -- Numeric subtraction
57+ --
58+ | Subtract
59+ -- |
60+ -- Numeric multiplication
61+ --
62+ | Multiply
63+ -- |
64+ -- Numeric division
65+ --
66+ | Divide
67+ -- |
68+ -- Remainder
69+ --
70+ | Modulus
71+ -- |
72+ -- Generic equality test
73+ --
74+ | EqualTo
75+ -- |
76+ -- Generic inequality test
77+ --
78+ | NotEqualTo
79+ -- |
80+ -- Numeric less-than
81+ --
82+ | LessThan
83+ -- |
84+ -- Numeric less-than-or-equal
85+ --
86+ | LessThanOrEqualTo
87+ -- |
88+ -- Numeric greater-than
89+ --
90+ | GreaterThan
91+ -- |
92+ -- Numeric greater-than-or-equal
93+ --
94+ | GreaterThanOrEqualTo
95+ -- |
96+ -- Boolean and
97+ --
98+ | And
99+ -- |
100+ -- Boolean or
101+ --
102+ | Or
103+ -- |
104+ -- Bitwise and
105+ --
106+ | BitwiseAnd
107+ -- |
108+ -- Bitwise or
109+ --
110+ | BitwiseOr
111+ -- |
112+ -- Bitwise xor
113+ --
114+ | BitwiseXor
115+ -- |
116+ -- Bitwise left shift
117+ --
118+ | ShiftLeft
119+ -- |
120+ -- Bitwise right shift
121+ --
122+ | ShiftRight
123+ -- |
124+ -- Bitwise right shift with zero-fill
125+ --
126+ | ZeroFillShiftRight deriving (Show, Eq, Data, Typeable)
127+
128+-- |
129+-- Data type for simplified Javascript expressions
130+--
131+data JS
132+ -- |
133+ -- A numeric literal
134+ --
135+ = JSNumericLiteral (Either Integer Double)
136+ -- |
137+ -- A string literal
138+ --
139+ | JSStringLiteral String
140+ -- |
141+ -- A boolean literal
142+ --
143+ | JSBooleanLiteral Bool
144+ -- |
145+ -- A unary operator application
146+ --
147+ | JSUnary UnaryOperator JS
148+ -- |
149+ -- A binary operator application
150+ --
151+ | JSBinary BinaryOperator JS JS
152+ -- |
153+ -- An array literal
154+ --
155+ | JSArrayLiteral [JS]
156+ -- |
157+ -- An array indexer expression
158+ --
159+ | JSIndexer JS JS
160+ -- |
161+ -- An object literal
162+ --
163+ | JSObjectLiteral [(String, JS)]
164+ -- |
165+ -- An object property accessor expression
166+ --
167+ | JSAccessor String JS
168+ -- |
169+ -- A function introduction (optional name, arguments, body)
170+ --
171+ | JSFunction (Maybe String) [String] JS
172+ -- |
173+ -- Function application
174+ --
175+ | JSApp JS [JS]
176+ -- |
177+ -- Variable
178+ --
179+ | JSVar String
180+ -- |
181+ -- Conditional expression
182+ --
183+ | JSConditional JS JS JS
184+ -- |
185+ -- A block of expressions in braces
186+ --
187+ | JSBlock [JS]
188+ -- |
189+ -- A variable introduction and optional initialization
190+ --
191+ | JSVariableIntroduction String (Maybe JS)
192+ -- |
193+ -- A variable assignment
194+ --
195+ | JSAssignment JS JS
196+ -- |
197+ -- While loop
198+ --
199+ | JSWhile JS JS
200+ -- |
201+ -- For loop
202+ --
203+ | JSFor String JS JS JS
204+ -- |
205+ -- ForIn loop
206+ --
207+ | JSForIn String JS JS
208+ -- |
209+ -- If-then-else statement
210+ --
211+ | JSIfElse JS JS (Maybe JS)
212+ -- |
213+ -- Return statement
214+ --
215+ | JSReturn JS
216+ -- |
217+ -- Throw statement
218+ --
219+ | JSThrow JS
220+ -- |
221+ -- Type-Of operator
222+ --
223+ | JSTypeOf JS
224+ -- |
225+ -- InstanceOf test
226+ --
227+ | JSInstanceOf JS JS
228+ -- |
229+ -- Labelled statement
230+ --
231+ | JSLabel String JS
232+ -- |
233+ -- Break statement
234+ --
235+ | JSBreak String
236+ -- |
237+ -- Continue statement
238+ --
239+ | JSContinue String
240+ -- |
241+ -- Raw Javascript (generated when parsing fails for an inline foreign import declaration)
242+ --
243+ | JSRaw String deriving (Show, Eq, Data, Typeable)
244+
245+--
246+-- Traversals
247+--
248+
249+everywhereOnJS :: (JS -> JS) -> JS -> JS
250+everywhereOnJS f = go
251+ where
252+ go :: JS -> JS
253+ go (JSUnary op j) = f (JSUnary op (go j))
254+ go (JSBinary op j1 j2) = f (JSBinary op (go j1) (go j2))
255+ go (JSArrayLiteral js) = f (JSArrayLiteral (map go js))
256+ go (JSIndexer j1 j2) = f (JSIndexer (go j1) (go j2))
257+ go (JSObjectLiteral js) = f (JSObjectLiteral (map (fmap go) js))
258+ go (JSAccessor prop j) = f (JSAccessor prop (go j))
259+ go (JSFunction name args j) = f (JSFunction name args (go j))
260+ go (JSApp j js) = f (JSApp (go j) (map go js))
261+ go (JSConditional j1 j2 j3) = f (JSConditional (go j1) (go j2) (go j3))
262+ go (JSBlock js) = f (JSBlock (map go js))
263+ go (JSVariableIntroduction name j) = f (JSVariableIntroduction name (fmap go j))
264+ go (JSAssignment j1 j2) = f (JSAssignment (go j1) (go j2))
265+ go (JSWhile j1 j2) = f (JSWhile (go j1) (go j2))
266+ go (JSFor name j1 j2 j3) = f (JSFor name (go j1) (go j2) (go j3))
267+ go (JSForIn name j1 j2) = f (JSForIn name (go j1) (go j2))
268+ go (JSIfElse j1 j2 j3) = f (JSIfElse (go j1) (go j2) (fmap go j3))
269+ go (JSReturn js) = f (JSReturn (go js))
270+ go (JSThrow js) = f (JSThrow (go js))
271+ go (JSTypeOf js) = f (JSTypeOf (go js))
272+ go (JSLabel name js) = f (JSLabel name (go js))
273+ go (JSInstanceOf j1 j2) = f (JSInstanceOf (go j1) (go j2))
274+ go other = f other
275+
276+everywhereOnJSTopDown :: (JS -> JS) -> JS -> JS
277+everywhereOnJSTopDown f = go . f
278+ where
279+ go :: JS -> JS
280+ go (JSUnary op j) = JSUnary op (go (f j))
281+ go (JSBinary op j1 j2) = JSBinary op (go (f j1)) (go (f j2))
282+ go (JSArrayLiteral js) = JSArrayLiteral (map (go . f) js)
283+ go (JSIndexer j1 j2) = JSIndexer (go (f j1)) (go (f j2))
284+ go (JSObjectLiteral js) = JSObjectLiteral (map (fmap (go . f)) js)
285+ go (JSAccessor prop j) = JSAccessor prop (go (f j))
286+ go (JSFunction name args j) = JSFunction name args (go (f j))
287+ go (JSApp j js) = JSApp (go (f j)) (map (go . f) js)
288+ go (JSConditional j1 j2 j3) = JSConditional (go (f j1)) (go (f j2)) (go (f j3))
289+ go (JSBlock js) = JSBlock (map (go . f) js)
290+ go (JSVariableIntroduction name j) = JSVariableIntroduction name (fmap (go . f) j)
291+ go (JSAssignment j1 j2) = JSAssignment (go (f j1)) (go (f j2))
292+ go (JSWhile j1 j2) = JSWhile (go (f j1)) (go (f j2))
293+ go (JSFor name j1 j2 j3) = JSFor name (go (f j1)) (go (f j2)) (go (f j3))
294+ go (JSForIn name j1 j2) = JSForIn name (go (f j1)) (go (f j2))
295+ go (JSIfElse j1 j2 j3) = JSIfElse (go (f j1)) (go (f j2)) (fmap (go . f) j3)
296+ go (JSReturn j) = JSReturn (go (f j))
297+ go (JSThrow j) = JSThrow (go (f j))
298+ go (JSTypeOf j) = JSTypeOf (go (f j))
299+ go (JSLabel name j) = JSLabel name (go (f j))
300+ go (JSInstanceOf j1 j2) = JSInstanceOf (go (f j1)) (go (f j2))
301+ go other = f other
302+
303+everythingOnJS :: (r -> r -> r) -> (JS -> r) -> JS -> r
304+everythingOnJS (<>) f = go
305+ where
306+ go j@(JSUnary _ j1) = f j <> go j1
307+ go j@(JSBinary _ j1 j2) = f j <> go j1 <> go j2
308+ go j@(JSArrayLiteral js) = foldl (<>) (f j) (map go js)
309+ go j@(JSIndexer j1 j2) = f j <> go j1 <> go j2
310+ go j@(JSObjectLiteral js) = foldl (<>) (f j) (map (go . snd) js)
311+ go j@(JSAccessor _ j1) = f j <> go j1
312+ go j@(JSFunction _ _ j1) = f j <> go j1
313+ go j@(JSApp j1 js) = foldl (<>) (f j <> go j1) (map go js)
314+ go j@(JSConditional j1 j2 j3) = f j <> go j1 <> go j2 <> go j3
315+ go j@(JSBlock js) = foldl (<>) (f j) (map go js)
316+ go j@(JSVariableIntroduction _ (Just j1)) = f j <> go j1
317+ go j@(JSAssignment j1 j2) = f j <> go j1 <> go j2
318+ go j@(JSWhile j1 j2) = f j <> go j1 <> go j2
319+ go j@(JSFor _ j1 j2 j3) = f j <> go j1 <> go j2 <> go j3
320+ go j@(JSForIn _ j1 j2) = f j <> go j1 <> go j2
321+ go j@(JSIfElse j1 j2 Nothing) = f j <> go j1 <> go j2
322+ go j@(JSIfElse j1 j2 (Just j3)) = f j <> go j1 <> go j2 <> go j3
323+ go j@(JSReturn j1) = f j <> go j1
324+ go j@(JSThrow j1) = f j <> go j1
325+ go j@(JSTypeOf j1) = f j <> go j1
326+ go j@(JSLabel _ j1) = f j <> go j1
327+ go j@(JSInstanceOf j1 j2) = f j <> go j1 <> go j2
328+ go other = f other
src/Language/PureScript/Constants.hsnew file+233
@@ -0,0 +1,233 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.Constants
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- Various constants which refer to things in the Prelude
13+--
14+-----------------------------------------------------------------------------
15+
16+module Language.PureScript.Constants where
17+
18+-- Prelude Operators
19+
20+($) :: String
21+($) = "$"
22+
23+(#) :: String
24+(#) = "#"
25+
26+(<>) :: String
27+(<>) = "<>"
28+
29+(++) :: String
30+(++) = "++"
31+
32+(>>=) :: String
33+(>>=) = ">>="
34+
35+(+) :: String
36+(+) = "+"
37+
38+(-) :: String
39+(-) = "-"
40+
41+(*) :: String
42+(*) = "*"
43+
44+(/) :: String
45+(/) = "/"
46+
47+(%) :: String
48+(%) = "%"
49+
50+(<) :: String
51+(<) = "<"
52+
53+(>) :: String
54+(>) = ">"
55+
56+(<=) :: String
57+(<=) = "<="
58+
59+(>=) :: String
60+(>=) = ">="
61+
62+(==) :: String
63+(==) = "=="
64+
65+(/=) :: String
66+(/=) = "/="
67+
68+(&) :: String
69+(&) = "&"
70+
71+bar :: String
72+bar = "|"
73+
74+(^) :: String
75+(^) = "^"
76+
77+(&&) :: String
78+(&&) = "&&"
79+
80+(||) :: String
81+(||) = "||"
82+
83+unsafeIndex :: String
84+unsafeIndex = "unsafeIndex"
85+
86+-- Prelude Operator Functions
87+
88+negate :: String
89+negate = "negate"
90+
91+shl :: String
92+shl = "shl"
93+
94+shr :: String
95+shr = "shr"
96+
97+zshr :: String
98+zshr = "zshr"
99+
100+complement :: String
101+complement = "complement"
102+
103+not :: String
104+not = "not"
105+
106+-- Prelude Values
107+
108+return :: String
109+return = "return"
110+
111+pure' :: String
112+pure' = "pure"
113+
114+returnEscaped :: String
115+returnEscaped = "$return"
116+
117+untilE :: String
118+untilE = "untilE"
119+
120+whileE :: String
121+whileE = "whileE"
122+
123+runST :: String
124+runST = "runST"
125+
126+runSTArray :: String
127+runSTArray = "runSTArray"
128+
129+stRefValue :: String
130+stRefValue = "value"
131+
132+newSTRef :: String
133+newSTRef = "newSTRef"
134+
135+readSTRef :: String
136+readSTRef = "readSTRef"
137+
138+writeSTRef :: String
139+writeSTRef = "writeSTRef"
140+
141+modifySTRef :: String
142+modifySTRef = "modifySTRef"
143+
144+peekSTArray :: String
145+peekSTArray = "peekSTArray"
146+
147+pokeSTArray :: String
148+pokeSTArray = "pokeSTArray"
149+
150+mkFn :: String
151+mkFn = "mkFn"
152+
153+runFn :: String
154+runFn = "runFn"
155+
156+unit :: String
157+unit = "unit"
158+
159+-- Prim values
160+
161+undefined :: String
162+undefined = "undefined"
163+
164+-- Type Class Dictionary Names
165+
166+monadEffDictionary :: String
167+monadEffDictionary = "monadEff"
168+
169+applicativeEffDictionary :: String
170+applicativeEffDictionary = "applicativeEff"
171+
172+bindEffDictionary :: String
173+bindEffDictionary = "bindEff"
174+
175+numNumber :: String
176+numNumber = "numNumber"
177+
178+ordNumber :: String
179+ordNumber = "ordNumber"
180+
181+eqNumber :: String
182+eqNumber = "eqNumber"
183+
184+eqString :: String
185+eqString = "eqString"
186+
187+eqBoolean :: String
188+eqBoolean = "eqBoolean"
189+
190+bitsNumber :: String
191+bitsNumber = "bitsNumber"
192+
193+boolLikeBoolean :: String
194+boolLikeBoolean = "boolLikeBoolean"
195+
196+semigroupString :: String
197+semigroupString = "semigroupString"
198+
199+semigroupoidArr :: String
200+semigroupoidArr = "semigroupoidArr"
201+
202+-- Main module
203+
204+main :: String
205+main = "main"
206+
207+-- Code Generation
208+
209+__superclass_ :: String
210+__superclass_ = "__superclass_"
211+
212+__unused :: String
213+__unused = "__unused"
214+
215+-- Modules
216+
217+prim :: String
218+prim = "Prim"
219+
220+prelude :: String
221+prelude = "Prelude"
222+
223+preludeUnsafe :: String
224+preludeUnsafe = "Prelude_Unsafe"
225+
226+eff :: String
227+eff = "Control_Monad_Eff"
228+
229+st :: String
230+st = "Control_Monad_ST"
231+
232+dataFunction :: String
233+dataFunction = "Data_Function"
src/Language/PureScript/DeadCodeElimination.hsnew file+113
@@ -0,0 +1,113 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.DeadCodeElimination
4+-- Copyright : (c) 2014 Phil Freeman
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+--
13+-----------------------------------------------------------------------------
14+
15+module Language.PureScript.DeadCodeElimination (
16+ eliminateDeadCode
17+) where
18+
19+import Data.List
20+import Data.Graph
21+import Data.Maybe (mapMaybe)
22+
23+import Language.PureScript.Names
24+import Language.PureScript.AST
25+
26+-- |
27+-- Eliminate all declarations which are not a transitive dependency of the entry point module
28+--
29+eliminateDeadCode :: [ModuleName] -> [Module] -> [Module]
30+eliminateDeadCode entryPoints ms = map go ms
31+ where
32+ go (Module moduleName ds (Just exps)) = Module moduleName ds' (Just exps')
33+ where
34+ ds' = filter (isUsed moduleName graph vertexFor entryPointVertices) ds
35+ exps' = mapMaybe (filterExport ds') exps
36+ go _ = error "Exports should have been elaborated in name desugaring"
37+ declarations = concatMap declarationsByModule ms
38+ (graph, _, vertexFor) = graphFromEdges $ map (\(key, deps) -> (key, key, deps)) declarations
39+ entryPointVertices = mapMaybe (vertexFor . fst) . filter (\((mn, _), _) -> mn `elem` entryPoints) $ declarations
40+
41+ filterExport :: [Declaration] -> DeclarationRef -> Maybe DeclarationRef
42+ filterExport decls r@(TypeRef name _) | (any $ typeOrClassExists name) decls = Just r
43+ filterExport decls r@(TypeClassRef name) | (any $ typeOrClassExists name) decls = Just r
44+ filterExport decls r@(ValueRef name) | (any $ valueExists name) decls = Just r
45+ filterExport decls r@(TypeInstanceRef name) | (any $ valueExists name) decls = Just r
46+ filterExport _ _ = Nothing
47+
48+ valueExists :: Ident -> Declaration -> Bool
49+ valueExists name (ValueDeclaration name' _ _ _) = name == name'
50+ valueExists name (ExternDeclaration _ name' _ _) = name == name'
51+ valueExists name (BindingGroupDeclaration decls) = any (\(name', _, _) -> name == name') decls
52+ valueExists name (PositionedDeclaration _ d) = valueExists name d
53+ valueExists _ _ = False
54+
55+ typeOrClassExists :: ProperName -> Declaration -> Bool
56+ typeOrClassExists name (DataDeclaration _ name' _ _) = name == name'
57+ typeOrClassExists name (TypeClassDeclaration name' _ _ _) = name == name'
58+ typeOrClassExists name (DataBindingGroupDeclaration decls) = any (typeOrClassExists name) decls
59+ typeOrClassExists name (PositionedDeclaration _ d) = typeOrClassExists name d
60+ typeOrClassExists _ _ = False
61+
62+type Key = (ModuleName, Either Ident ProperName)
63+
64+declarationsByModule :: Module -> [(Key, [Key])]
65+declarationsByModule (Module moduleName ds _) = concatMap go ds
66+ where
67+ go :: Declaration -> [(Key, [Key])]
68+ go d@(ValueDeclaration name _ _ _) = [((moduleName, Left name), dependencies moduleName d)]
69+ go (DataDeclaration _ _ _ dctors) = map (\(name, _) -> ((moduleName, Right name), [])) dctors
70+ go (ExternDeclaration _ name _ _) = [((moduleName, Left name), [])]
71+ go d@(BindingGroupDeclaration names') = map (\(name, _, _) -> ((moduleName, Left name), dependencies moduleName d)) names'
72+ go (DataBindingGroupDeclaration ds') = concatMap go ds'
73+ go (TypeClassDeclaration name _ _ _) = [((moduleName, Right name), [])]
74+ go (PositionedDeclaration _ d) = go d
75+ go _ = []
76+
77+dependencies :: ModuleName -> Declaration -> [Key]
78+dependencies moduleName =
79+ let (f, _, _, _, _) = everythingOnValues (++) (const []) values (const []) (const []) (const [])
80+ in nub . f
81+ where
82+ values :: Expr -> [Key]
83+ values (Var ident) = let (mn, name) = qualify moduleName ident in [(mn, Left name)]
84+ values (Constructor (Qualified (Just mn) name)) = [(mn, Right name)]
85+ values (Constructor (Qualified Nothing _)) = error "Found unqualified data constructor"
86+ values (TypeClassDictionaryConstructorApp (Qualified (Just mn) name) _) = [(mn, Right name)]
87+ values (TypeClassDictionaryConstructorApp (Qualified Nothing _) _) = error "Found unqualified class dictionary constructor"
88+ values _ = []
89+
90+isUsed :: ModuleName -> Graph -> (Key -> Maybe Vertex) -> [Vertex] -> Declaration -> Bool
91+isUsed moduleName graph vertexFor entryPointVertices (ValueDeclaration name _ _ _) =
92+ let Just v' = vertexFor (moduleName, Left name)
93+ in any (\v -> path graph v v') entryPointVertices
94+isUsed moduleName graph vertexFor entryPointVertices (FixityDeclaration _ name) =
95+ let Just v' = vertexFor (moduleName, Left $ Op name)
96+ in any (\v -> path graph v v') entryPointVertices
97+isUsed moduleName graph vertexFor entryPointVertices (DataDeclaration _ _ _ dctors) =
98+ any (\(pn, _) -> let Just v' = vertexFor (moduleName, Right pn)
99+ in any (\v -> path graph v v') entryPointVertices) dctors
100+isUsed moduleName graph vertexFor entryPointVertices (ExternDeclaration _ name _ _) =
101+ let Just v' = vertexFor (moduleName, Left name)
102+ in any (\v -> path graph v v') entryPointVertices
103+isUsed moduleName graph vertexFor entryPointVertices (BindingGroupDeclaration ds) =
104+ any (\(name, _, _) -> let Just v' = vertexFor (moduleName, Left name)
105+ in any (\v -> path graph v v') entryPointVertices) ds
106+isUsed moduleName graph vertexFor entryPointVertices (DataBindingGroupDeclaration ds) =
107+ any (isUsed moduleName graph vertexFor entryPointVertices) ds
108+isUsed moduleName graph vertexFor entryPointVertices (TypeClassDeclaration name _ _ _) =
109+ let Just v' = vertexFor (moduleName, Right name)
110+ in any (\v -> path graph v v') entryPointVertices
111+isUsed moduleName graph vertexFor entryPointVertices (PositionedDeclaration _ d) =
112+ isUsed moduleName graph vertexFor entryPointVertices d
113+isUsed _ _ _ _ _ = True
src/Language/PureScript/Environment.hsnew file+221
@@ -0,0 +1,221 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.Environment
4+-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+--
13+-----------------------------------------------------------------------------
14+
15+{-# LANGUAGE DeriveDataTypeable #-}
16+
17+module Language.PureScript.Environment where
18+
19+import Data.Data
20+
21+import Language.PureScript.Names
22+import Language.PureScript.Types
23+import Language.PureScript.Kinds
24+import Language.PureScript.TypeClassDictionaries
25+import qualified Language.PureScript.Constants as C
26+
27+import qualified Data.Map as M
28+
29+-- |
30+-- The @Environment@ defines all values and types which are currently in scope:
31+--
32+data Environment = Environment {
33+ -- |
34+ -- Value names currently in scope
35+ --
36+ names :: M.Map (ModuleName, Ident) (Type, NameKind, NameVisibility)
37+ -- |
38+ -- Type names currently in scope
39+ --
40+ , types :: M.Map (Qualified ProperName) (Kind, TypeKind)
41+ -- |
42+ -- Data constructors currently in scope, along with their associated data type constructors
43+ --
44+ , dataConstructors :: M.Map (Qualified ProperName) (DataDeclType, ProperName, Type)
45+ -- |
46+ -- Type synonyms currently in scope
47+ --
48+ , typeSynonyms :: M.Map (Qualified ProperName) ([(String, Maybe Kind)], Type)
49+ -- |
50+ -- Available type class dictionaries
51+ --
52+ , typeClassDictionaries :: M.Map (Qualified Ident, Maybe ModuleName) TypeClassDictionaryInScope
53+ -- |
54+ -- Type classes
55+ --
56+ , typeClasses :: M.Map (Qualified ProperName) ([(String, Maybe Kind)], [(Ident, Type)], [(Qualified ProperName, [Type])])
57+ } deriving (Show)
58+
59+-- |
60+-- The initial environment with no values and only the default javascript types defined
61+--
62+initEnvironment :: Environment
63+initEnvironment = Environment M.empty primTypes M.empty M.empty M.empty M.empty
64+
65+-- |
66+-- The type of a foreign import
67+--
68+data ForeignImportType
69+ -- |
70+ -- A regular foreign import
71+ --
72+ = ForeignImport
73+ -- |
74+ -- A foreign import which contains inline Javascript as a string literal
75+ --
76+ | InlineJavascript deriving (Show, Eq, Data, Typeable)
77+
78+-- |
79+-- The visibility of a name in scope
80+--
81+data NameVisibility
82+ -- |
83+ -- The name is defined in the current binding group, but is not visible
84+ --
85+ = Undefined
86+ -- |
87+ -- The name is defined in the another binding group, or has been made visible by a function binder
88+ --
89+ | Defined deriving (Show, Eq)
90+
91+-- |
92+-- The kind of a name
93+--
94+data NameKind
95+ -- |
96+ -- A value introduced as a binding in a module
97+ --
98+ = Value
99+ -- |
100+ -- A type class dictionary member accessor import, generated during desugaring of type class declarations
101+ --
102+ | TypeClassAccessorImport
103+ -- |
104+ -- A foreign import
105+ --
106+ | Extern ForeignImportType
107+ -- |
108+ -- A local name introduced using a lambda abstraction, variable introduction or binder
109+ --
110+ | LocalVariable
111+ -- |
112+ -- A data constructor
113+ --
114+ | DataConstructor
115+ -- |
116+ -- A type class dictionary, generated during desugaring of type class declarations
117+ --
118+ | TypeInstanceDictionaryValue deriving (Show, Eq, Data, Typeable)
119+
120+-- |
121+-- The kinds of a type
122+--
123+data TypeKind
124+ -- |
125+ -- Data type
126+ --
127+ = DataType [(String, Maybe Kind)] [(ProperName, [Type])]
128+ -- |
129+ -- Type synonym
130+ --
131+ | TypeSynonym
132+ -- |
133+ -- Foreign data
134+ --
135+ | ExternData
136+ -- |
137+ -- A local type variable
138+ --
139+ | LocalTypeVariable deriving (Show, Eq, Data, Typeable)
140+
141+-- |
142+-- The type ('data' or 'newtype') of a data type declaration
143+--
144+data DataDeclType
145+ -- |
146+ -- A standard data constructor
147+ --
148+ = Data
149+ -- |
150+ -- A newtype constructor
151+ --
152+ | Newtype deriving (Eq, Ord, Data, Typeable)
153+
154+instance Show DataDeclType where
155+ show Data = "data"
156+ show Newtype = "newtype"
157+
158+-- |
159+-- Construct a ProperName in the Prim module
160+--
161+primName :: String -> Qualified ProperName
162+primName = Qualified (Just $ ModuleName [ProperName C.prim]) . ProperName
163+
164+-- |
165+-- Construct a type in the Prim module
166+--
167+primTy :: String -> Type
168+primTy = TypeConstructor . primName
169+
170+-- |
171+-- Type constructor for functions
172+--
173+tyFunction :: Type
174+tyFunction = primTy "Function"
175+
176+-- |
177+-- Type constructor for strings
178+--
179+tyString :: Type
180+tyString = primTy "String"
181+
182+-- |
183+-- Type constructor for numbers
184+--
185+tyNumber :: Type
186+tyNumber = primTy "Number"
187+
188+-- |
189+-- Type constructor for booleans
190+--
191+tyBoolean :: Type
192+tyBoolean = primTy "Boolean"
193+
194+-- |
195+-- Type constructor for arrays
196+--
197+tyArray :: Type
198+tyArray = primTy "Array"
199+
200+-- |
201+-- Type constructor for objects
202+--
203+tyObject :: Type
204+tyObject = primTy "Object"
205+
206+-- |
207+-- Smart constructor for function types
208+--
209+function :: Type -> Type -> Type
210+function t1 = TypeApp (TypeApp tyFunction t1)
211+
212+-- |
213+-- The primitive types in the external javascript environment with their associated kinds.
214+--
215+primTypes :: M.Map (Qualified ProperName) (Kind, TypeKind)
216+primTypes = M.fromList [ (primName "Function" , (FunKind Star (FunKind Star Star), ExternData))
217+ , (primName "Array" , (FunKind Star Star, ExternData))
218+ , (primName "Object" , (FunKind (Row Star) Star, ExternData))
219+ , (primName "String" , (Star, ExternData))
220+ , (primName "Number" , (Star, ExternData))
221+ , (primName "Boolean" , (Star, ExternData)) ]
src/Language/PureScript/Errors.hsnew file+140
@@ -0,0 +1,140 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.Error
4+-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+--
13+-----------------------------------------------------------------------------
14+
15+{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleContexts #-}
16+
17+module Language.PureScript.Errors where
18+
19+import Data.Either (lefts, rights)
20+import Data.List (intersperse, intercalate)
21+import Data.Monoid
22+
23+import Control.Monad.Error
24+import Control.Applicative ((<$>))
25+
26+import Language.PureScript.AST
27+import Language.PureScript.Pretty
28+import Language.PureScript.Types
29+
30+-- |
31+-- Type for sources of type checking errors
32+--
33+data ErrorSource
34+ -- |
35+ -- An error which originated at a Expr
36+ --
37+ = ExprError Expr
38+ -- |
39+ -- An error which originated at a Type
40+ --
41+ | TypeError Type deriving (Show)
42+
43+-- |
44+-- Compilation errors
45+--
46+data CompileError
47+ = CompileError
48+ { -- |
49+ -- Error message
50+ --
51+ compileErrorMessage :: String
52+ -- |
53+ -- The value where the error occurred
54+ --
55+ , compileErrorValue :: Maybe ErrorSource
56+ -- |
57+ -- Optional source position information
58+ --
59+ , compileErrorPosition :: Maybe SourcePos
60+ }
61+ deriving (Show)
62+
63+-- |
64+-- A stack trace for an error
65+--
66+data ErrorStack
67+ = ErrorStack { runErrorStack :: [CompileError] }
68+ | MultipleErrors [ErrorStack] deriving (Show)
69+
70+instance Monoid ErrorStack where
71+ mempty = ErrorStack []
72+ mappend (ErrorStack xs) (ErrorStack ys) = ErrorStack (xs ++ ys)
73+ mappend (MultipleErrors es) x = MultipleErrors [ e <> x | e <- es ]
74+ mappend x (MultipleErrors es) = MultipleErrors [ x <> e | e <- es ]
75+
76+instance Error ErrorStack where
77+ strMsg s = ErrorStack [CompileError s Nothing Nothing]
78+ noMsg = ErrorStack []
79+
80+prettyPrintErrorStack :: Bool -> ErrorStack -> String
81+prettyPrintErrorStack printFullStack (ErrorStack es) =
82+ case mconcat $ map (Last . compileErrorPosition) es of
83+ Last (Just sourcePos) -> "Error at " ++ show sourcePos ++ ": \n" ++ prettyPrintErrorStack'
84+ _ -> prettyPrintErrorStack'
85+ where
86+ prettyPrintErrorStack' :: String
87+ prettyPrintErrorStack'
88+ | printFullStack = intercalate "\n" (map showError (filter isErrorNonEmpty es))
89+ | otherwise =
90+ let
91+ es' = filter isErrorNonEmpty es
92+ in case length es' of
93+ 1 -> showError (head es')
94+ _ -> showError (head es') ++ "\n" ++ showError (last es')
95+prettyPrintErrorStack printFullStack (MultipleErrors es) =
96+ unlines $ intersperse "" $ "Multiple errors:" : map (prettyPrintErrorStack printFullStack) es
97+
98+stringifyErrorStack :: Bool -> Either ErrorStack a -> Either String a
99+stringifyErrorStack printFullStack = either (Left . prettyPrintErrorStack printFullStack) Right
100+
101+isErrorNonEmpty :: CompileError -> Bool
102+isErrorNonEmpty = not . null . compileErrorMessage
103+
104+showError :: CompileError -> String
105+showError (CompileError msg Nothing _) = msg
106+showError (CompileError msg (Just (ExprError val)) _) = "Error in expression " ++ prettyPrintValue val ++ ":\n" ++ msg
107+showError (CompileError msg (Just (TypeError ty)) _) = "Error in type " ++ prettyPrintType ty ++ ":\n" ++ msg
108+
109+mkErrorStack :: String -> Maybe ErrorSource -> ErrorStack
110+mkErrorStack msg t = ErrorStack [CompileError msg t Nothing]
111+
112+positionError :: SourcePos -> ErrorStack
113+positionError pos = ErrorStack [CompileError "" Nothing (Just pos)]
114+
115+-- |
116+-- Rethrow an error with a more detailed error message in the case of failure
117+--
118+rethrow :: (MonadError e m) => (e -> e) -> m a -> m a
119+rethrow f = flip catchError $ \e -> throwError (f e)
120+
121+-- |
122+-- Rethrow an error with source position information
123+--
124+rethrowWithPosition :: (MonadError ErrorStack m) => SourcePos -> m a -> m a
125+rethrowWithPosition pos = rethrow (positionError pos <>)
126+
127+-- |
128+-- Collect errors in in parallel
129+--
130+parU :: (MonadError ErrorStack m, Functor m) => [a] -> (a -> m b) -> m [b]
131+parU xs f = forM xs (withError . f) >>= collectErrors
132+ where
133+ withError :: (MonadError ErrorStack m, Functor m) => m a -> m (Either ErrorStack a)
134+ withError u = catchError (Right <$> u) (return . Left)
135+
136+ collectErrors :: (MonadError ErrorStack m, Functor m) => [Either ErrorStack a] -> m [a]
137+ collectErrors es = case lefts es of
138+ [err] -> throwError err
139+ [] -> return $ rights es
140+ errs -> throwError $ MultipleErrors errs
src/Language/PureScript/Kinds.hsnew file+60
@@ -0,0 +1,60 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.Kinds
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+--
13+-----------------------------------------------------------------------------
14+
15+{-# LANGUAGE DeriveDataTypeable #-}
16+
17+module Language.PureScript.Kinds where
18+
19+import Data.Data
20+
21+import Control.Monad.Unify (Unknown)
22+
23+-- |
24+-- The data type of kinds
25+--
26+data Kind
27+ -- |
28+ -- Unification variable of type Kind
29+ --
30+ = KUnknown Unknown
31+ -- |
32+ -- The kind of types
33+ --
34+ | Star
35+ -- |
36+ -- The kind of effects
37+ --
38+ | Bang
39+ -- |
40+ -- Kinds for labelled, unordered rows without duplicates
41+ --
42+ | Row Kind
43+ -- |
44+ -- Function kinds
45+ --
46+ | FunKind Kind Kind deriving (Show, Eq, Data, Typeable)
47+
48+everywhereOnKinds :: (Kind -> Kind) -> Kind -> Kind
49+everywhereOnKinds f = go
50+ where
51+ go (Row k1) = f (Row (go k1))
52+ go (FunKind k1 k2) = f (FunKind (go k1) (go k2))
53+ go other = f other
54+
55+everythingOnKinds :: (r -> r -> r) -> (Kind -> r) -> Kind -> r
56+everythingOnKinds (<>) f = go
57+ where
58+ go k@(Row k1) = f k <> go k1
59+ go k@(FunKind k1 k2) = f k <> go k1 <> go k2
60+ go other = f other
src/Language/PureScript/ModuleDependencies.hsnew file+76
@@ -0,0 +1,76 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.ModuleDependencies
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- | Provides the ability to sort modules based on module dependencies
12+--
13+-----------------------------------------------------------------------------
14+
15+module Language.PureScript.ModuleDependencies (
16+ sortModules,
17+ ModuleGraph
18+) where
19+
20+import Data.Graph
21+import Data.List (nub)
22+import Data.Maybe (mapMaybe)
23+
24+import Language.PureScript.AST
25+import Language.PureScript.Names
26+import Language.PureScript.Types
27+
28+-- |
29+-- A list of modules with their dependencies
30+--
31+type ModuleGraph = [(ModuleName, [ModuleName])]
32+
33+-- |
34+-- Sort a collection of modules based on module dependencies.
35+--
36+-- Reports an error if the module graph contains a cycle.
37+--
38+sortModules :: [Module] -> Either String ([Module], ModuleGraph)
39+sortModules ms = do
40+ let verts = map (\m@(Module _ ds _) -> (m, getModuleName m, nub (concatMap usedModules ds))) ms
41+ ms' <- mapM toModule $ stronglyConnComp verts
42+ let moduleGraph = map (\(_, mn, deps) -> (mn, deps)) verts
43+ return (ms', moduleGraph)
44+
45+-- |
46+-- Calculate a list of used modules based on explicit imports and qualified names
47+--
48+usedModules :: Declaration -> [ModuleName]
49+usedModules = let (f, _, _, _, _) = everythingOnValues (++) forDecls forValues (const []) (const []) (const []) in nub . f
50+ where
51+ forDecls :: Declaration -> [ModuleName]
52+ forDecls (ImportDeclaration mn _ _) = [mn]
53+ forDecls _ = []
54+
55+ forValues :: Expr -> [ModuleName]
56+ forValues (Var (Qualified (Just mn) _)) = [mn]
57+ forValues (BinaryNoParens (Qualified (Just mn) _) _ _) = [mn]
58+ forValues (Constructor (Qualified (Just mn) _)) = [mn]
59+ forValues (TypedValue _ _ ty) = forTypes ty
60+ forValues _ = []
61+
62+ forTypes :: Type -> [ModuleName]
63+ forTypes (TypeConstructor (Qualified (Just mn) _)) = [mn]
64+ forTypes (ConstrainedType cs _) = mapMaybe (\(Qualified mn _, _) -> mn) cs
65+ forTypes _ = []
66+
67+getModuleName :: Module -> ModuleName
68+getModuleName (Module mn _ _) = mn
69+
70+-- |
71+-- Convert a strongly connected component of the module graph to a module
72+--
73+toModule :: SCC Module -> Either String Module
74+toModule (AcyclicSCC m) = return m
75+toModule (CyclicSCC [m]) = return m
76+toModule (CyclicSCC ms) = Left $ "Cycle in module dependencies: " ++ show (map getModuleName ms)
src/Language/PureScript/Names.hsnew file+85
@@ -0,0 +1,85 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.Names
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- Data types for names
13+--
14+-----------------------------------------------------------------------------
15+
16+{-# LANGUAGE DeriveDataTypeable #-}
17+
18+module Language.PureScript.Names where
19+
20+import Data.List
21+import Data.Data
22+
23+-- |
24+-- Names for value identifiers
25+--
26+data Ident
27+ -- |
28+ -- An alphanumeric identifier
29+ --
30+ = Ident String
31+ -- |
32+ -- A symbolic name for an infix operator
33+ --
34+ | Op String deriving (Eq, Ord, Data, Typeable)
35+
36+runIdent :: Ident -> String
37+runIdent (Ident i) = i
38+runIdent (Op op) = op
39+
40+instance Show Ident where
41+ show (Ident s) = s
42+ show (Op op) = '(':op ++ ")"
43+
44+-- |
45+-- Proper names, i.e. capitalized names for e.g. module names, type//data constructors.
46+--
47+newtype ProperName = ProperName { runProperName :: String } deriving (Eq, Ord, Data, Typeable)
48+
49+instance Show ProperName where
50+ show = runProperName
51+
52+-- |
53+-- Module names
54+--
55+data ModuleName = ModuleName [ProperName] deriving (Eq, Ord, Data, Typeable)
56+
57+runModuleName :: ModuleName -> String
58+runModuleName (ModuleName pns) = intercalate "." (runProperName `map` pns)
59+
60+moduleNameFromString :: String -> ModuleName
61+moduleNameFromString = ModuleName . splitProperNames
62+ where
63+ splitProperNames s = case dropWhile (== '.') s of
64+ "" -> []
65+ s' -> ProperName w : splitProperNames s''
66+ where (w, s'') = break (== '.') s'
67+
68+instance Show ModuleName where
69+ show = runModuleName
70+
71+-- |
72+-- A qualified name, i.e. a name with an optional module name
73+--
74+data Qualified a = Qualified (Maybe ModuleName) a deriving (Eq, Ord, Data, Typeable)
75+
76+instance (Show a) => Show (Qualified a) where
77+ show (Qualified Nothing a) = show a
78+ show (Qualified (Just name) a) = show name ++ "." ++ show a
79+
80+-- |
81+-- Provide a default module name, if a name is unqualified
82+--
83+qualify :: ModuleName -> Qualified a -> (ModuleName, a)
84+qualify m (Qualified Nothing a) = (m, a)
85+qualify _ (Qualified (Just m) a) = (m, a)
src/Language/PureScript/Optimizer.hsnew file+76
@@ -0,0 +1,76 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.Optimizer
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- This module optimizes code in the simplified-Javascript intermediate representation.
13+--
14+-- The following optimizations are supported:
15+--
16+-- * Collapsing nested blocks
17+--
18+-- * Tail call elimination
19+--
20+-- * Inlining of (>>=) and ret for the Eff monad
21+--
22+-- * Removal of unnecessary thunks
23+--
24+-- * Eta conversion
25+--
26+-- * Inlining variables
27+--
28+-- * Inline Prelude.($), Prelude.(#), Prelude.(++), Prelude.(!!)
29+--
30+-- * Inlining primitive Javascript operators
31+--
32+-----------------------------------------------------------------------------
33+
34+module Language.PureScript.Optimizer (
35+ optimize
36+) where
37+
38+import Language.PureScript.CodeGen.JS.AST
39+import Language.PureScript.Options
40+import qualified Language.PureScript.Constants as C
41+
42+import Language.PureScript.Optimizer.Common
43+import Language.PureScript.Optimizer.TCO
44+import Language.PureScript.Optimizer.MagicDo
45+import Language.PureScript.Optimizer.Inliner
46+import Language.PureScript.Optimizer.Unused
47+import Language.PureScript.Optimizer.Blocks
48+
49+-- |
50+-- Apply a series of optimizer passes to simplified Javascript code
51+--
52+optimize :: Options mode -> JS -> JS
53+optimize opts | optionsNoOptimizations opts = id
54+ | otherwise = untilFixedPoint (applyAll
55+ [ collapseNestedBlocks
56+ , collapseNestedIfs
57+ , tco opts
58+ , magicDo opts
59+ , removeCodeAfterReturnStatements
60+ , removeUnusedArg
61+ , removeUndefinedApp
62+ , unThunk
63+ , etaConvert
64+ , evaluateIifes
65+ , inlineVariables
66+ , inlineOperator (C.prelude, (C.$)) $ \f x -> JSApp f [x]
67+ , inlineOperator (C.prelude, (C.#)) $ \x f -> JSApp f [x]
68+ , inlineOperator (C.preludeUnsafe, C.unsafeIndex) $ flip JSIndexer
69+ , inlineCommonOperators ])
70+
71+untilFixedPoint :: (Eq a) => (a -> a) -> a -> a
72+untilFixedPoint f = go
73+ where
74+ go a = let a' = f a in
75+ if a' == a then a' else go a'
76+
src/Language/PureScript/Optimizer/Blocks.hsnew file+42
@@ -0,0 +1,42 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.Optimizer.Blocks
4+-- Copyright : (c) Phil Freeman 2013-14
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- Optimizer steps for simplifying Javascript blocks
13+--
14+-----------------------------------------------------------------------------
15+
16+module Language.PureScript.Optimizer.Blocks
17+ ( collapseNestedBlocks
18+ , collapseNestedIfs
19+ ) where
20+
21+import Language.PureScript.CodeGen.JS.AST
22+
23+-- |
24+-- Collapse blocks which appear nested directly below another block
25+--
26+collapseNestedBlocks :: JS -> JS
27+collapseNestedBlocks = everywhereOnJS collapse
28+ where
29+ collapse :: JS -> JS
30+ collapse (JSBlock sts) = JSBlock (concatMap go sts)
31+ collapse js = js
32+ go :: JS -> [JS]
33+ go (JSBlock sts) = sts
34+ go s = [s]
35+
36+collapseNestedIfs :: JS -> JS
37+collapseNestedIfs = everywhereOnJS collapse
38+ where
39+ collapse :: JS -> JS
40+ collapse (JSIfElse cond1 (JSBlock [JSIfElse cond2 body Nothing]) Nothing) =
41+ JSIfElse (JSBinary And cond1 cond2) body Nothing
42+ collapse js = js
src/Language/PureScript/Optimizer/Common.hsnew file+77
@@ -0,0 +1,77 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.Optimizer.Common
4+-- Copyright : (c) Phil Freeman 2013-14
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- Common functions used by the various optimizer phases
13+--
14+-----------------------------------------------------------------------------
15+
16+module Language.PureScript.Optimizer.Common where
17+
18+import Data.Maybe (fromMaybe)
19+
20+import Language.PureScript.CodeGen.JS.AST
21+
22+applyAll :: [a -> a] -> a -> a
23+applyAll = foldl1 (.)
24+
25+replaceIdent :: String -> JS -> JS -> JS
26+replaceIdent var1 js = everywhereOnJS replace
27+ where
28+ replace (JSVar var2) | var1 == var2 = js
29+ replace other = other
30+
31+replaceIdents :: [(String, JS)] -> JS -> JS
32+replaceIdents vars = everywhereOnJS replace
33+ where
34+ replace v@(JSVar var) = fromMaybe v $ lookup var vars
35+ replace other = other
36+
37+isReassigned :: String -> JS -> Bool
38+isReassigned var1 = everythingOnJS (||) check
39+ where
40+ check :: JS -> Bool
41+ check (JSFunction _ args _) | var1 `elem` args = True
42+ check (JSVariableIntroduction arg _) | var1 == arg = True
43+ check (JSAssignment (JSVar arg) _) | var1 == arg = True
44+ check (JSFor arg _ _ _) | var1 == arg = True
45+ check (JSForIn arg _ _) | var1 == arg = True
46+ check _ = False
47+
48+isRebound :: JS -> JS -> Bool
49+isRebound js d = any (\v -> isReassigned v d || isUpdated v d) (everythingOnJS (++) variablesOf js)
50+ where
51+ variablesOf (JSVar var) = [var]
52+ variablesOf _ = []
53+
54+isUsed :: String -> JS -> Bool
55+isUsed var1 = everythingOnJS (||) check
56+ where
57+ check :: JS -> Bool
58+ check (JSVar var2) | var1 == var2 = True
59+ check (JSAssignment target _) | var1 == targetVariable target = True
60+ check _ = False
61+
62+targetVariable :: JS -> String
63+targetVariable (JSVar var) = var
64+targetVariable (JSAccessor _ tgt) = targetVariable tgt
65+targetVariable (JSIndexer _ tgt) = targetVariable tgt
66+targetVariable _ = error "Invalid argument to targetVariable"
67+
68+isUpdated :: String -> JS -> Bool
69+isUpdated var1 = everythingOnJS (||) check
70+ where
71+ check :: JS -> Bool
72+ check (JSAssignment target _) | var1 == targetVariable target = True
73+ check _ = False
74+
75+removeFromBlock :: ([JS] -> [JS]) -> JS -> JS
76+removeFromBlock go (JSBlock sts) = JSBlock (go sts)
77+removeFromBlock _ js = js
src/Language/PureScript/Optimizer/Inliner.hsnew file+192
@@ -0,0 +1,192 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.Optimizer.Inliner
4+-- Copyright : (c) Phil Freeman 2013-14
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- This module provides basic inlining capabilities
13+--
14+-----------------------------------------------------------------------------
15+
16+module Language.PureScript.Optimizer.Inliner (
17+ inlineVariables,
18+ inlineOperator,
19+ inlineCommonOperators,
20+ etaConvert,
21+ unThunk,
22+ evaluateIifes
23+) where
24+
25+import Data.Maybe (fromMaybe)
26+
27+import Language.PureScript.CodeGen.JS.AST
28+import Language.PureScript.CodeGen.Common (identToJs)
29+import Language.PureScript.Optimizer.Common
30+import Language.PureScript.Names
31+
32+import qualified Language.PureScript.Constants as C
33+
34+shouldInline :: JS -> Bool
35+shouldInline (JSVar _) = True
36+shouldInline (JSNumericLiteral _) = True
37+shouldInline (JSStringLiteral _) = True
38+shouldInline (JSBooleanLiteral _) = True
39+shouldInline (JSAccessor _ val) = shouldInline val
40+shouldInline (JSIndexer index val) = shouldInline index && shouldInline val
41+shouldInline _ = False
42+
43+etaConvert :: JS -> JS
44+etaConvert = everywhereOnJS convert
45+ where
46+ convert :: JS -> JS
47+ convert (JSBlock [JSReturn (JSApp (JSFunction Nothing idents block@(JSBlock body)) args)])
48+ | all shouldInline args &&
49+ not (any (`isRebound` block) (map JSVar idents)) &&
50+ not (any (`isRebound` block) args)
51+ = JSBlock (map (replaceIdents (zip idents args)) body)
52+ convert (JSFunction Nothing [] (JSBlock [JSReturn (JSApp fn [])])) = fn
53+ convert js = js
54+
55+unThunk :: JS -> JS
56+unThunk = everywhereOnJS convert
57+ where
58+ convert :: JS -> JS
59+ convert (JSBlock []) = JSBlock []
60+ convert (JSBlock jss) =
61+ case last jss of
62+ JSReturn (JSApp (JSFunction Nothing [] (JSBlock body)) []) -> JSBlock $ init jss ++ body
63+ _ -> JSBlock jss
64+ convert js = js
65+
66+evaluateIifes :: JS -> JS
67+evaluateIifes = everywhereOnJS convert
68+ where
69+ convert :: JS -> JS
70+ convert (JSApp (JSFunction Nothing [] (JSBlock [JSReturn ret])) []) = ret
71+ convert js = js
72+
73+inlineVariables :: JS -> JS
74+inlineVariables = everywhereOnJS $ removeFromBlock go
75+ where
76+ go :: [JS] -> [JS]
77+ go [] = []
78+ go (JSVariableIntroduction var (Just js) : sts)
79+ | shouldInline js && not (any (isReassigned var) sts) && not (any (isRebound js) sts) && not (any (isUpdated var) sts) =
80+ go (map (replaceIdent var js) sts)
81+ go (s:sts) = s : go sts
82+
83+inlineOperator :: (String, String) -> (JS -> JS -> JS) -> JS -> JS
84+inlineOperator (m, op) f = everywhereOnJS convert
85+ where
86+ convert :: JS -> JS
87+ convert (JSApp (JSApp op' [x]) [y]) | isOp op' = f x y
88+ convert other = other
89+ isOp (JSAccessor longForm (JSVar m')) = m == m' && longForm == identToJs (Op op)
90+ isOp (JSIndexer (JSStringLiteral op') (JSVar m')) = m == m' && op == op'
91+ isOp _ = False
92+
93+inlineCommonOperators :: JS -> JS
94+inlineCommonOperators = applyAll $
95+ [ binary C.numNumber (C.+) Add
96+ , binary C.numNumber (C.-) Subtract
97+ , binary C.numNumber (C.*) Multiply
98+ , binary C.numNumber (C./) Divide
99+ , binary C.numNumber (C.%) Modulus
100+ , unary C.numNumber C.negate Negate
101+
102+ , binary C.ordNumber (C.<) LessThan
103+ , binary C.ordNumber (C.>) GreaterThan
104+ , binary C.ordNumber (C.<=) LessThanOrEqualTo
105+ , binary C.ordNumber (C.>=) GreaterThanOrEqualTo
106+
107+ , binary C.eqNumber (C.==) EqualTo
108+ , binary C.eqNumber (C./=) NotEqualTo
109+ , binary C.eqString (C.==) EqualTo
110+ , binary C.eqString (C./=) NotEqualTo
111+ , binary C.eqBoolean (C.==) EqualTo
112+ , binary C.eqBoolean (C./=) NotEqualTo
113+
114+ , binary C.semigroupString (C.<>) Add
115+ , binary C.semigroupString (C.++) Add
116+
117+ , binaryFunction C.bitsNumber C.shl ShiftLeft
118+ , binaryFunction C.bitsNumber C.shr ShiftRight
119+ , binaryFunction C.bitsNumber C.zshr ZeroFillShiftRight
120+ , binary C.bitsNumber (C.&) BitwiseAnd
121+ , binary C.bitsNumber C.bar BitwiseOr
122+ , binary C.bitsNumber (C.^) BitwiseXor
123+ , unary C.bitsNumber C.complement BitwiseNot
124+
125+ , binary C.boolLikeBoolean (C.&&) And
126+ , binary C.boolLikeBoolean (C.||) Or
127+ , unary C.boolLikeBoolean C.not Not
128+ ] ++
129+ [ fn | i <- [0..10], fn <- [ mkFn i, runFn i ] ]
130+ where
131+ binary :: String -> String -> BinaryOperator -> JS -> JS
132+ binary dictName opString op = everywhereOnJS convert
133+ where
134+ convert :: JS -> JS
135+ convert (JSApp (JSApp (JSApp fn [dict]) [x]) [y]) | isOp fn && isOpDict dictName dict = JSBinary op x y
136+ convert other = other
137+ isOp (JSAccessor longForm (JSAccessor prelude (JSVar _))) = prelude == C.prelude && longForm == identToJs (Op opString)
138+ isOp (JSIndexer (JSStringLiteral op') (JSVar prelude)) = prelude == C.prelude && opString == op'
139+ isOp _ = False
140+ binaryFunction :: String -> String -> BinaryOperator -> JS -> JS
141+ binaryFunction dictName fnName op = everywhereOnJS convert
142+ where
143+ convert :: JS -> JS
144+ convert (JSApp (JSApp (JSApp fn [dict]) [x]) [y]) | isOp fn && isOpDict dictName dict = JSBinary op x y
145+ convert other = other
146+ isOp (JSAccessor fnName' (JSVar prelude)) = prelude == C.prelude && fnName == fnName'
147+ isOp _ = False
148+ unary :: String -> String -> UnaryOperator -> JS -> JS
149+ unary dictName fnName op = everywhereOnJS convert
150+ where
151+ convert :: JS -> JS
152+ convert (JSApp (JSApp fn [dict]) [x]) | isOp fn && isOpDict dictName dict = JSUnary op x
153+ convert other = other
154+ isOp (JSAccessor fnName' (JSVar prelude)) = prelude == C.prelude && fnName' == fnName
155+ isOp _ = False
156+ isOpDict dictName (JSAccessor prop (JSVar prelude)) = prelude == C.prelude && prop == dictName
157+ isOpDict _ _ = False
158+ mkFn :: Int -> JS -> JS
159+ mkFn 0 = everywhereOnJS convert
160+ where
161+ convert :: JS -> JS
162+ convert (JSApp mkFnN [JSFunction Nothing [_] (JSBlock js)]) | isNFn C.mkFn 0 mkFnN =
163+ JSFunction Nothing [] (JSBlock js)
164+ convert other = other
165+ mkFn n = everywhereOnJS convert
166+ where
167+ convert :: JS -> JS
168+ convert orig@(JSApp mkFnN [fn]) | isNFn C.mkFn n mkFnN =
169+ case collectArgs n [] fn of
170+ Just (args, js) -> JSFunction Nothing args (JSBlock js)
171+ Nothing -> orig
172+ convert other = other
173+ collectArgs :: Int -> [String] -> JS -> Maybe ([String], [JS])
174+ collectArgs 1 acc (JSFunction Nothing [oneArg] (JSBlock js)) | length acc == n - 1 = Just (reverse (oneArg : acc), js)
175+ collectArgs m acc (JSFunction Nothing [oneArg] (JSBlock [JSReturn ret])) = collectArgs (m - 1) (oneArg : acc) ret
176+ collectArgs _ _ _ = Nothing
177+
178+ isNFn :: String -> Int -> JS -> Bool
179+ isNFn prefix n (JSVar name) = name == (prefix ++ show n)
180+ isNFn prefix n (JSAccessor name (JSVar dataFunction)) | dataFunction == C.dataFunction = name == (prefix ++ show n)
181+ isNFn _ _ _ = False
182+
183+ runFn :: Int -> JS -> JS
184+ runFn n = everywhereOnJS convert
185+ where
186+ convert :: JS -> JS
187+ convert js = fromMaybe js $ go n [] js
188+
189+ go :: Int -> [JS] -> JS -> Maybe JS
190+ go 0 acc (JSApp runFnN [fn]) | isNFn C.runFn n runFnN && length acc == n = Just (JSApp fn acc)
191+ go m acc (JSApp lhs [arg]) = go (m - 1) (arg : acc) lhs
192+ go _ _ _ = Nothing
src/Language/PureScript/Optimizer/MagicDo.hsnew file+166
@@ -0,0 +1,166 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.Optimizer.MagicDo
4+-- Copyright : (c) Phil Freeman 2013-14
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- This module implements the "Magic Do" optimization, which inlines calls to return
13+-- and bind for the Eff monad, as well as some of its actions.
14+--
15+-----------------------------------------------------------------------------
16+
17+module Language.PureScript.Optimizer.MagicDo (
18+ magicDo
19+) where
20+
21+import Data.List (nub)
22+import Data.Maybe (fromJust, isJust)
23+
24+import Language.PureScript.Options
25+import Language.PureScript.CodeGen.JS.AST
26+import Language.PureScript.CodeGen.Common (identToJs)
27+import Language.PureScript.Names
28+
29+import qualified Language.PureScript.Constants as C
30+
31+magicDo :: Options mode -> JS -> JS
32+magicDo opts | optionsNoMagicDo opts = id
33+ | otherwise = inlineST . magicDo'
34+
35+-- |
36+-- Inline type class dictionaries for >>= and return for the Eff monad
37+--
38+-- E.g.
39+--
40+-- Prelude[">>="](dict)(m1)(function(x) {
41+-- return ...;
42+-- })
43+--
44+-- becomes
45+--
46+-- function __do {
47+-- var x = m1();
48+-- ...
49+-- }
50+--
51+magicDo' :: JS -> JS
52+magicDo' = everywhereOnJS undo . everywhereOnJSTopDown convert
53+ where
54+ -- The name of the function block which is added to denote a do block
55+ fnName = "__do"
56+ -- Desugar monomorphic calls to >>= and return for the Eff monad
57+ convert :: JS -> JS
58+ -- Desugar return
59+ convert (JSApp (JSApp ret [val]) []) | isReturn ret = val
60+ -- Desugar pure
61+ convert (JSApp (JSApp pure' [val]) []) | isPure pure' = val
62+ -- Desugar >>
63+ convert (JSApp (JSApp bind [m]) [JSFunction Nothing [] (JSBlock js)]) | isBind bind && isJSReturn (last js) =
64+ let JSReturn ret = last js in
65+ JSFunction (Just fnName) [] $ JSBlock (JSApp m [] : init js ++ [JSReturn (JSApp ret [])] )
66+ -- Desugar >>=
67+ convert (JSApp (JSApp bind [m]) [JSFunction Nothing [arg] (JSBlock js)]) | isBind bind && isJSReturn (last js) =
68+ let JSReturn ret = last js in
69+ JSFunction (Just fnName) [] $ JSBlock (JSVariableIntroduction arg (Just (JSApp m [])) : init js ++ [JSReturn (JSApp ret [])] )
70+ -- Desugar untilE
71+ convert (JSApp (JSApp f [arg]) []) | isEffFunc C.untilE f =
72+ JSApp (JSFunction Nothing [] (JSBlock [ JSWhile (JSUnary Not (JSApp arg [])) (JSBlock []), JSReturn $ JSObjectLiteral []])) []
73+ -- Desugar whileE
74+ convert (JSApp (JSApp (JSApp f [arg1]) [arg2]) []) | isEffFunc C.whileE f =
75+ JSApp (JSFunction Nothing [] (JSBlock [ JSWhile (JSApp arg1 []) (JSBlock [ JSApp arg2 [] ]), JSReturn $ JSObjectLiteral []])) []
76+ convert other = other
77+ -- Check if an expression represents a monomorphic call to >>= for the Eff monad
78+ isBind (JSApp bindPoly [effDict]) | isBindPoly bindPoly && isEffDict C.bindEffDictionary effDict = True
79+ isBind _ = False
80+ -- Check if an expression represents a monomorphic call to return for the Eff monad
81+ isReturn (JSApp retPoly [effDict]) | isRetPoly retPoly && isEffDict C.monadEffDictionary effDict = True
82+ isReturn _ = False
83+ -- Check if an expression represents a monomorphic call to pure for the Eff applicative
84+ isPure (JSApp purePoly [effDict]) | isPurePoly purePoly && isEffDict C.applicativeEffDictionary effDict = True
85+ isPure _ = False
86+ -- Check if an expression represents the polymorphic >>= function
87+ isBindPoly (JSAccessor prop (JSVar prelude)) = prelude == C.prelude && prop == identToJs (Op (C.>>=))
88+ isBindPoly (JSIndexer (JSStringLiteral bind) (JSVar prelude)) = prelude == C.prelude && bind == (C.>>=)
89+ isBindPoly _ = False
90+ -- Check if an expression represents the polymorphic return function
91+ isRetPoly (JSAccessor returnEscaped (JSVar prelude)) = prelude == C.prelude && returnEscaped == C.returnEscaped
92+ isRetPoly (JSIndexer (JSStringLiteral return') (JSVar prelude)) = prelude == C.prelude && return' == C.return
93+ isRetPoly _ = False
94+ -- Check if an expression represents the polymorphic pure function
95+ isPurePoly (JSAccessor pure' (JSVar prelude)) = prelude == C.prelude && pure' == C.pure'
96+ isPurePoly (JSIndexer (JSStringLiteral pure') (JSVar prelude)) = prelude == C.prelude && pure' == C.pure'
97+ isPurePoly _ = False
98+ -- Check if an expression represents a function in the Ef module
99+ isEffFunc name (JSAccessor name' (JSVar eff)) = eff == C.eff && name == name'
100+ isEffFunc _ _ = False
101+ -- Check if an expression represents the Monad Eff dictionary
102+ isEffDict name (JSVar ident) | ident == name = True
103+ isEffDict name (JSAccessor prop (JSVar eff)) = eff == C.eff && prop == name
104+ isEffDict _ _ = False
105+ -- Remove __do function applications which remain after desugaring
106+ undo :: JS -> JS
107+ undo (JSReturn (JSApp (JSFunction (Just ident) [] body) [])) | ident == fnName = body
108+ undo other = other
109+
110+ isJSReturn (JSReturn _) = True
111+ isJSReturn _ = False
112+
113+-- |
114+-- Inline functions in the ST module
115+--
116+inlineST :: JS -> JS
117+inlineST = everywhereOnJS convertBlock
118+ where
119+ -- Look for runST blocks and inline the STRefs there.
120+ -- If all STRefs are used in the scope of the same runST, only using { read, write, modify }STRef then
121+ -- we can be more aggressive about inlining, and actually turn STRefs into local variables.
122+ convertBlock (JSApp f [arg]) | isSTFunc C.runST f || isSTFunc C.runSTArray f =
123+ let refs = nub . findSTRefsIn $ arg
124+ usages = findAllSTUsagesIn arg
125+ allUsagesAreLocalVars = all (\u -> let v = toVar u in isJust v && fromJust v `elem` refs) usages
126+ localVarsDoNotEscape = all (\r -> length (r `appearingIn` arg) == length (filter (\u -> let v = toVar u in v == Just r) usages)) refs
127+ in everywhereOnJS (convert (allUsagesAreLocalVars && localVarsDoNotEscape)) arg
128+ convertBlock other = other
129+ -- Convert a block in a safe way, preserving object wrappers of references,
130+ -- or in a more aggressive way, turning wrappers into local variables depending on the
131+ -- agg(ressive) parameter.
132+ convert agg (JSApp f [arg]) | isSTFunc C.newSTRef f =
133+ JSFunction Nothing [] (JSBlock [JSReturn $ if agg then arg else JSObjectLiteral [(C.stRefValue, arg)]])
134+ convert agg (JSApp (JSApp f [ref]) []) | isSTFunc C.readSTRef f =
135+ if agg then ref else JSAccessor C.stRefValue ref
136+ convert agg (JSApp (JSApp (JSApp f [ref]) [arg]) []) | isSTFunc C.writeSTRef f =
137+ if agg then JSAssignment ref arg else JSAssignment (JSAccessor C.stRefValue ref) arg
138+ convert agg (JSApp (JSApp (JSApp f [ref]) [func]) []) | isSTFunc C.modifySTRef f =
139+ if agg then JSAssignment ref (JSApp func [ref]) else JSAssignment (JSAccessor C.stRefValue ref) (JSApp func [JSAccessor C.stRefValue ref])
140+ convert _ (JSApp (JSApp (JSApp f [arr]) [i]) []) | isSTFunc C.peekSTArray f =
141+ JSIndexer i arr
142+ convert _ (JSApp (JSApp (JSApp (JSApp f [arr]) [i]) [val]) []) | isSTFunc C.pokeSTArray f =
143+ JSAssignment (JSIndexer i arr) val
144+ convert _ other = other
145+ -- Check if an expression represents a function in the ST module
146+ isSTFunc name (JSAccessor name' (JSVar st)) = st == C.st && name == name'
147+ isSTFunc _ _ = False
148+ -- Find all ST Refs initialized in this block
149+ findSTRefsIn = everythingOnJS (++) isSTRef
150+ where
151+ isSTRef (JSVariableIntroduction ident (Just (JSApp (JSApp f [_]) []))) | isSTFunc C.newSTRef f = [ident]
152+ isSTRef _ = []
153+ -- Find all STRefs used as arguments to readSTRef, writeSTRef, modifySTRef
154+ findAllSTUsagesIn = everythingOnJS (++) isSTUsage
155+ where
156+ isSTUsage (JSApp (JSApp f [ref]) []) | isSTFunc C.readSTRef f = [ref]
157+ isSTUsage (JSApp (JSApp (JSApp f [ref]) [_]) []) | isSTFunc C.writeSTRef f || isSTFunc C.modifySTRef f = [ref]
158+ isSTUsage _ = []
159+ -- Find all uses of a variable
160+ appearingIn ref = everythingOnJS (++) isVar
161+ where
162+ isVar e@(JSVar v) | v == ref = [e]
163+ isVar _ = []
164+ -- Convert a JS value to a String if it is a JSVar
165+ toVar (JSVar v) = Just v
166+ toVar _ = Nothing
src/Language/PureScript/Optimizer/TCO.hsnew file+103
@@ -0,0 +1,103 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.Optimizer.TCO
4+-- Copyright : (c) Phil Freeman 2013-14
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- This module implements tail call elimination.
13+--
14+-----------------------------------------------------------------------------
15+
16+module Language.PureScript.Optimizer.TCO (tco) where
17+
18+import Language.PureScript.Options
19+import Language.PureScript.CodeGen.JS.AST
20+
21+-- |
22+-- Eliminate tail calls
23+--
24+tco :: Options mode -> JS -> JS
25+tco opts | optionsNoTco opts = id
26+ | otherwise = tco'
27+
28+tco' :: JS -> JS
29+tco' = everywhereOnJS convert
30+ where
31+ tcoLabel :: String
32+ tcoLabel = "tco"
33+ tcoVar :: String -> String
34+ tcoVar arg = "__tco_" ++ arg
35+ copyVar :: String -> String
36+ copyVar arg = "__copy_" ++ arg
37+ convert :: JS -> JS
38+ convert js@(JSVariableIntroduction name (Just fn@JSFunction {})) =
39+ let
40+ (argss, body', replace) = collectAllFunctionArgs [] id fn
41+ in case () of
42+ _ | isTailCall name body' ->
43+ let
44+ allArgs = concat $ reverse argss
45+ in
46+ JSVariableIntroduction name (Just (replace (toLoop name allArgs body')))
47+ | otherwise -> js
48+ convert js = js
49+ collectAllFunctionArgs :: [[String]] -> (JS -> JS) -> JS -> ([[String]], JS, JS -> JS)
50+ collectAllFunctionArgs allArgs f (JSFunction ident args (JSBlock (body@(JSReturn _):_))) =
51+ collectAllFunctionArgs (args : allArgs) (\b -> f (JSFunction ident (map copyVar args) (JSBlock [b]))) body
52+ collectAllFunctionArgs allArgs f (JSFunction ident args body@(JSBlock _)) =
53+ (args : allArgs, body, f . JSFunction ident (map copyVar args))
54+ collectAllFunctionArgs allArgs f (JSReturn (JSFunction ident args (JSBlock [body]))) =
55+ collectAllFunctionArgs (args : allArgs) (\b -> f (JSReturn (JSFunction ident (map copyVar args) (JSBlock [b])))) body
56+ collectAllFunctionArgs allArgs f (JSReturn (JSFunction ident args body@(JSBlock _))) =
57+ (args : allArgs, body, f . JSReturn . JSFunction ident (map copyVar args))
58+ collectAllFunctionArgs allArgs f body = (allArgs, body, f)
59+ isTailCall :: String -> JS -> Bool
60+ isTailCall ident js =
61+ let
62+ numSelfCalls = everythingOnJS (+) countSelfCalls js
63+ numSelfCallsInTailPosition = everythingOnJS (+) countSelfCallsInTailPosition js
64+ numSelfCallsUnderFunctions = everythingOnJS (+) countSelfCallsUnderFunctions js
65+ in
66+ numSelfCalls > 0
67+ && numSelfCalls == numSelfCallsInTailPosition
68+ && numSelfCallsUnderFunctions == 0
69+ where
70+ countSelfCalls :: JS -> Int
71+ countSelfCalls (JSApp (JSVar ident') _) | ident == ident' = 1
72+ countSelfCalls _ = 0
73+ countSelfCallsInTailPosition :: JS -> Int
74+ countSelfCallsInTailPosition (JSReturn ret) | isSelfCall ident ret = 1
75+ countSelfCallsInTailPosition _ = 0
76+ countSelfCallsUnderFunctions (JSFunction _ _ js') = everythingOnJS (+) countSelfCalls js'
77+ countSelfCallsUnderFunctions _ = 0
78+ toLoop :: String -> [String] -> JS -> JS
79+ toLoop ident allArgs js = JSBlock $
80+ map (\arg -> JSVariableIntroduction arg (Just (JSVar (copyVar arg)))) allArgs ++
81+ [ JSLabel tcoLabel $ JSWhile (JSBooleanLiteral True) (JSBlock [ everywhereOnJS loopify js ]) ]
82+ where
83+ loopify :: JS -> JS
84+ loopify (JSReturn ret) | isSelfCall ident ret =
85+ let
86+ allArgumentValues = concat $ collectSelfCallArgs [] ret
87+ in
88+ JSBlock $ zipWith (\val arg ->
89+ JSVariableIntroduction (tcoVar arg) (Just val)) allArgumentValues allArgs
90+ ++ map (\arg ->
91+ JSAssignment (JSVar arg) (JSVar (tcoVar arg))) allArgs
92+ ++ [ JSContinue tcoLabel ]
93+ loopify other = other
94+ collectSelfCallArgs :: [[JS]] -> JS -> [[JS]]
95+ collectSelfCallArgs allArgumentValues (JSApp fn args') = collectSelfCallArgs (args' : allArgumentValues) fn
96+ collectSelfCallArgs allArgumentValues _ = allArgumentValues
97+ isSelfCall :: String -> JS -> Bool
98+ isSelfCall ident (JSApp (JSVar ident') args) | ident == ident' && not (any isFunction args) = True
99+ isSelfCall ident (JSApp fn args) | not (any isFunction args) = isSelfCall ident fn
100+ isSelfCall _ _ = False
101+ isFunction :: JS -> Bool
102+ isFunction (JSFunction _ _ _) = True
103+ isFunction _ = False
src/Language/PureScript/Optimizer/Unused.hsnew file+46
@@ -0,0 +1,46 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.Optimizer.Unused
4+-- Copyright : (c) Phil Freeman 2013-14
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- Removes unused variables
13+--
14+-----------------------------------------------------------------------------
15+
16+module Language.PureScript.Optimizer.Unused
17+ ( removeCodeAfterReturnStatements
18+ , removeUnusedArg
19+ , removeUndefinedApp
20+ ) where
21+
22+import Language.PureScript.CodeGen.JS.AST
23+import Language.PureScript.Optimizer.Common
24+
25+import qualified Language.PureScript.Constants as C
26+
27+removeCodeAfterReturnStatements :: JS -> JS
28+removeCodeAfterReturnStatements = everywhereOnJS (removeFromBlock go)
29+ where
30+ go :: [JS] -> [JS]
31+ go jss | not (any isJSReturn jss) = jss
32+ | otherwise = let (body, ret : _) = span (not . isJSReturn) jss in body ++ [ret]
33+ isJSReturn (JSReturn _) = True
34+ isJSReturn _ = False
35+
36+removeUnusedArg :: JS -> JS
37+removeUnusedArg = everywhereOnJS convert
38+ where
39+ convert (JSFunction name [arg] body) | arg == C.__unused = JSFunction name [] body
40+ convert js = js
41+
42+removeUndefinedApp :: JS -> JS
43+removeUndefinedApp = everywhereOnJS convert
44+ where
45+ convert (JSApp fn [JSVar arg]) | arg == C.undefined = JSApp fn []
46+ convert js = js
src/Language/PureScript/Options.hsnew file+89
@@ -0,0 +1,89 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.Options
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- The data type of compiler options
13+--
14+-----------------------------------------------------------------------------
15+
16+{-# LANGUAGE GADTs, DataKinds, StandaloneDeriving #-}
17+
18+module Language.PureScript.Options where
19+
20+-- |
21+-- Indicates the mode of the compiler. Lifted using DataKinds to refine the Options type.
22+--
23+data Mode = Compile | Make
24+
25+-- |
26+-- Per-mode options
27+--
28+data ModeOptions mode where
29+ CompileOptions :: String -> [String] -> [String] -> ModeOptions Compile
30+ MakeOptions :: ModeOptions Make
31+
32+browserNamespace :: ModeOptions Compile -> String
33+browserNamespace (CompileOptions ns _ _) = ns
34+
35+entryPointModules :: ModeOptions Compile -> [String]
36+entryPointModules (CompileOptions _ ms _) = ms
37+
38+codeGenModules :: ModeOptions Compile -> [String]
39+codeGenModules (CompileOptions _ _ ms) = ms
40+
41+deriving instance Show (ModeOptions mode)
42+
43+-- |
44+-- The data type of compiler options
45+--
46+data Options mode = Options {
47+ -- |
48+ -- Disable inclusion of the built in Prelude
49+ --
50+ optionsNoPrelude :: Bool
51+ -- |
52+ -- Disable tail-call elimination
53+ --
54+ , optionsNoTco :: Bool
55+ -- |
56+ -- Disable inlining of calls to return and bind for the Eff monad
57+ --
58+ , optionsNoMagicDo :: Bool
59+ -- |
60+ -- When specified, checks the type of `main` in the module, and generate a call to run main
61+ -- after the module definitions.
62+ --
63+ , optionsMain :: Maybe String
64+ -- |
65+ -- Skip all optimizations
66+ --
67+ , optionsNoOptimizations :: Bool
68+ -- |
69+ -- Verbose error message
70+ --
71+ , optionsVerboseErrors :: Bool
72+ -- |
73+ -- Specify the namespace that PureScript modules will be exported to when running in the
74+ -- browser.
75+ --
76+ , optionsAdditional :: ModeOptions mode
77+ } deriving Show
78+
79+-- |
80+-- Default compiler options
81+--
82+defaultCompileOptions :: Options Compile
83+defaultCompileOptions = Options False False False Nothing False False (CompileOptions "PS" [] [])
84+
85+-- |
86+-- Default make options
87+--
88+defaultMakeOptions :: Options Make
89+defaultMakeOptions = Options False False False Nothing False False MakeOptions
src/Language/PureScript/Parser.hsnew file+34
@@ -0,0 +1,34 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.Parser
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- A collection of parsers for core data types:
13+--
14+-- [@Language.PureScript.Parser.Kinds@] Parser for kinds
15+--
16+-- [@Language.PureScript.Parser.Values@] Parser for values
17+--
18+-- [@Language.PureScript.Parser.Types@] Parser for types
19+--
20+-- [@Language.PureScript.Parser.Declaration@] Parsers for declarations and modules
21+--
22+-- [@Language.PureScript.Parser.State@] Parser state, including indentation
23+--
24+-- [@Language.PureScript.Parser.Common@] Common parsing utility functions
25+--
26+-----------------------------------------------------------------------------
27+
28+module Language.PureScript.Parser (module P) where
29+
30+import Language.PureScript.Parser.Common as P
31+import Language.PureScript.Parser.Types as P
32+import Language.PureScript.Parser.State as P
33+import Language.PureScript.Parser.Kinds as P
34+import Language.PureScript.Parser.Declarations as P
src/Language/PureScript/Parser/Common.hsnew file+387
@@ -0,0 +1,387 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.Parser.Common
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- Constants, and utility functions to be used when parsing
13+--
14+-----------------------------------------------------------------------------
15+
16+{-# LANGUAGE FlexibleContexts #-}
17+
18+module Language.PureScript.Parser.Common where
19+
20+import Data.Functor.Identity
21+import Control.Applicative
22+import Control.Monad
23+import Language.PureScript.Parser.State
24+import qualified Text.Parsec as P
25+import qualified Text.Parsec.Token as PT
26+
27+import Language.PureScript.Names
28+
29+-- |
30+-- A list of purescript reserved identifiers
31+--
32+reservedPsNames :: [String]
33+reservedPsNames = [ "data"
34+ , "newtype"
35+ , "type"
36+ , "foreign"
37+ , "import"
38+ , "infixl"
39+ , "infixr"
40+ , "infix"
41+ , "class"
42+ , "instance"
43+ , "module"
44+ , "case"
45+ , "of"
46+ , "if"
47+ , "then"
48+ , "else"
49+ , "do"
50+ , "let"
51+ , "true"
52+ , "false"
53+ , "in"
54+ , "where"
55+ ]
56+
57+-- |
58+-- The characters allowed for use in operators
59+--
60+opChars :: [Char]
61+opChars = ":!#$%&*+./<=>?@\\^|-~"
62+
63+-- |
64+-- A list of reserved identifiers for types
65+--
66+reservedTypeNames :: [String]
67+reservedTypeNames = [ "forall"
68+ , "where" ]
69+
70+-- |
71+-- A list of reserved operators
72+--
73+reservedOpNames :: [String]
74+reservedOpNames = [ "=>", "->", "=", ".", "\\" ]
75+
76+-- |
77+-- Valid first characters for an identifier
78+--
79+identStart :: P.Parsec String u Char
80+identStart = P.lower <|> P.oneOf "_"
81+
82+-- |
83+-- Valid identifier characters
84+--
85+identLetter :: P.Parsec String u Char
86+identLetter = P.alphaNum <|> P.oneOf "_'"
87+
88+-- |
89+-- Valid first characters for an operator
90+--
91+opStart :: P.Parsec String u Char
92+opStart = P.oneOf opChars
93+
94+-- |
95+-- Valid operators characters
96+--
97+opLetter :: P.Parsec String u Char
98+opLetter = P.oneOf opChars
99+
100+-- |
101+-- The PureScript language definition
102+--
103+langDef :: PT.GenLanguageDef String u Identity
104+langDef = PT.LanguageDef
105+ { PT.reservedNames = reservedPsNames
106+ , PT.reservedOpNames = reservedOpNames
107+ , PT.commentStart = "{-"
108+ , PT.commentEnd = "-}"
109+ , PT.commentLine = "--"
110+ , PT.nestedComments = True
111+ , PT.identStart = identStart
112+ , PT.identLetter = identLetter
113+ , PT.opStart = opStart
114+ , PT.opLetter = opLetter
115+ , PT.caseSensitive = True
116+ }
117+
118+-- |
119+-- A token parser based on the language definition
120+--
121+tokenParser :: PT.GenTokenParser String u Identity
122+tokenParser = PT.makeTokenParser langDef
123+
124+-- |
125+-- Parse a token
126+--
127+lexeme :: P.Parsec String u a -> P.Parsec String u a
128+lexeme = PT.lexeme tokenParser
129+
130+-- |
131+-- Parse an identifier
132+--
133+identifier :: P.Parsec String u String
134+identifier = PT.identifier tokenParser
135+
136+-- |
137+-- Parse an identifier in a more permissive position
138+--
139+identifierName :: P.Parsec String u String
140+identifierName = lexeme $ (:) <$> identStart <*> many identLetter
141+
142+-- |
143+-- Parse a reserved word
144+--
145+reserved :: String -> P.Parsec String u ()
146+reserved = PT.reserved tokenParser
147+
148+-- |
149+-- Parse a reserved operator
150+--
151+reservedOp :: String -> P.Parsec String u ()
152+reservedOp = PT.reservedOp tokenParser
153+
154+-- |
155+-- Parse an operator
156+--
157+operator :: P.Parsec String u String
158+operator = PT.operator tokenParser
159+
160+-- |
161+-- Parse a string literal
162+--
163+stringLiteral :: P.Parsec String u String
164+stringLiteral = lexeme blockString <|> PT.stringLiteral tokenParser
165+ where delimeter = P.try (P.string "\"\"\"")
166+ blockString = delimeter >> P.manyTill P.anyChar delimeter
167+
168+-- |
169+-- Parse whitespace
170+--
171+whiteSpace :: P.Parsec String u ()
172+whiteSpace = PT.whiteSpace tokenParser
173+
174+-- |
175+-- Semicolon
176+--
177+semi :: P.Parsec String u String
178+semi = PT.semi tokenParser
179+
180+-- |
181+-- Colon
182+--
183+colon :: P.Parsec String u String
184+colon = PT.colon tokenParser
185+
186+-- |
187+-- Period
188+--
189+dot :: P.Parsec String u String
190+dot = PT.dot tokenParser
191+
192+-- |
193+-- Comma
194+--
195+comma :: P.Parsec String u String
196+comma = PT.comma tokenParser
197+
198+-- |
199+-- Backtick
200+--
201+tick :: P.Parsec String u Char
202+tick = lexeme $ P.char '`'
203+
204+-- |
205+-- Pipe character
206+--
207+pipe :: P.Parsec String u Char
208+pipe = lexeme $ P.char '|'
209+
210+-- |
211+-- Natural number
212+--
213+natural :: P.Parsec String u Integer
214+natural = PT.natural tokenParser
215+
216+-- |
217+-- Parse a proper name
218+--
219+properName :: P.Parsec String u ProperName
220+properName = lexeme $ ProperName <$> P.try ((:) <$> P.upper <*> many P.alphaNum P.<?> "name")
221+
222+-- |
223+-- Parse a module name
224+--
225+moduleName :: P.Parsec String ParseState ModuleName
226+moduleName = ModuleName <$> P.try (sepBy properName dot)
227+
228+-- |
229+-- Parse a qualified name, i.e. M.name or just name
230+--
231+parseQualified :: P.Parsec String ParseState a -> P.Parsec String ParseState (Qualified a)
232+parseQualified parser = part []
233+ where
234+ part path = (do name <- P.try (properName <* delimiter)
235+ part (updatePath path name))
236+ <|> (Qualified (qual path) <$> P.try parser)
237+ delimiter = indented *> dot <* P.notFollowedBy dot
238+ updatePath path name = path ++ [name]
239+ qual path = if null path then Nothing else Just $ ModuleName path
240+
241+-- |
242+-- Parse an integer or floating point value
243+--
244+integerOrFloat :: P.Parsec String u (Either Integer Double)
245+integerOrFloat = (Right <$> P.try (PT.float tokenParser) <|>
246+ Left <$> P.try (PT.natural tokenParser)) P.<?> "number"
247+
248+-- |
249+-- Parse an identifier or parenthesized operator
250+--
251+parseIdent :: P.Parsec String ParseState Ident
252+parseIdent = (Ident <$> identifier) <|> (Op <$> parens operator)
253+
254+-- |
255+-- Parse a token inside square brackets
256+--
257+squares :: P.Parsec String ParseState a -> P.Parsec String ParseState a
258+squares = P.between (lexeme $ P.char '[') (lexeme $ indented *> P.char ']') . (indented *>)
259+
260+-- |
261+-- Parse a token inside parentheses
262+--
263+parens :: P.Parsec String ParseState a -> P.Parsec String ParseState a
264+parens = P.between (lexeme $ P.char '(') (lexeme $ indented *> P.char ')') . (indented *>)
265+
266+-- |
267+-- Parse a token inside braces
268+--
269+braces :: P.Parsec String ParseState a -> P.Parsec String ParseState a
270+braces = P.between (lexeme $ P.char '{') (lexeme $ indented *> P.char '}') . (indented *>)
271+
272+-- |
273+-- Parse a token inside angle brackets
274+--
275+angles :: P.Parsec String ParseState a -> P.Parsec String ParseState a
276+angles = P.between (lexeme $ P.char '<') (lexeme $ indented *> P.char '>') . (indented *>)
277+
278+-- |
279+-- Parse zero or more values separated by a separator token
280+--
281+sepBy :: P.Parsec String ParseState a -> P.Parsec String ParseState sep -> P.Parsec String ParseState [a]
282+sepBy p s = P.sepBy (indented *> p) (indented *> s)
283+
284+-- |
285+-- Parse one or more values separated by a separator token
286+--
287+sepBy1 :: P.Parsec String ParseState a -> P.Parsec String ParseState sep -> P.Parsec String ParseState [a]
288+sepBy1 p s = P.sepBy1 (indented *> p) (indented *> s)
289+
290+-- |
291+-- Parse zero or more values separated by semicolons
292+--
293+semiSep :: P.Parsec String ParseState a -> P.Parsec String ParseState [a]
294+semiSep = flip sepBy semi
295+
296+-- |
297+-- Parse one or more values separated by semicolons
298+--
299+semiSep1 :: P.Parsec String ParseState a -> P.Parsec String ParseState [a]
300+semiSep1 = flip sepBy1 semi
301+
302+-- |
303+-- Parse zero or more values separated by commas
304+--
305+commaSep :: P.Parsec String ParseState a -> P.Parsec String ParseState [a]
306+commaSep = flip sepBy comma
307+
308+-- |
309+-- Parse one or more values separated by commas
310+--
311+commaSep1 :: P.Parsec String ParseState a -> P.Parsec String ParseState [a]
312+commaSep1 = flip sepBy1 comma
313+
314+-- |
315+-- Run the first parser, then match the second if possible, applying the specified function on a successful match
316+--
317+augment :: P.Stream s m t => P.ParsecT s u m a -> P.ParsecT s u m b -> (a -> b -> a) -> P.ParsecT s u m a
318+augment p q f = flip (maybe id $ flip f) <$> p <*> P.optionMaybe q
319+
320+-- |
321+-- Run the first parser, then match the second zero or more times, applying the specified function for each match
322+--
323+fold :: P.Stream s m t => P.ParsecT s u m a -> P.ParsecT s u m b -> (a -> b -> a) -> P.ParsecT s u m a
324+fold first more combine = do
325+ a <- first
326+ bs <- P.many more
327+ return $ foldl combine a bs
328+
329+-- |
330+-- Build a parser from a smaller parser and a list of parsers for postfix operators
331+--
332+buildPostfixParser :: P.Stream s m t => [a -> P.ParsecT s u m a] -> P.ParsecT s u m a -> P.ParsecT s u m a
333+buildPostfixParser fs first = do
334+ a <- first
335+ go a
336+ where
337+ go a = do
338+ maybeA <- P.optionMaybe $ P.choice (map ($ a) fs)
339+ case maybeA of
340+ Nothing -> return a
341+ Just a' -> go a'
342+
343+-- |
344+-- Parse an identifier in backticks or an operator
345+--
346+parseIdentInfix :: P.Parsec String ParseState (Qualified Ident)
347+parseIdentInfix = P.between tick tick (parseQualified (Ident <$> identifier)) <|> (parseQualified (Op <$> operator))
348+
349+-- |
350+-- Mark the current indentation level
351+--
352+mark :: P.Parsec String ParseState a -> P.Parsec String ParseState a
353+mark p = do
354+ current <- indentationLevel <$> P.getState
355+ pos <- P.sourceColumn <$> P.getPosition
356+ P.modifyState $ \st -> st { indentationLevel = pos }
357+ a <- p
358+ P.modifyState $ \st -> st { indentationLevel = current }
359+ return a
360+
361+-- |
362+-- Check that the current identation level matches a predicate
363+--
364+checkIndentation :: (P.Column -> P.Column -> Bool) -> P.Parsec String ParseState ()
365+checkIndentation rel = do
366+ col <- P.sourceColumn <$> P.getPosition
367+ current <- indentationLevel <$> P.getState
368+ guard (col `rel` current)
369+
370+-- |
371+-- Check that the current indentation level is past the current mark
372+--
373+indented :: P.Parsec String ParseState ()
374+indented = checkIndentation (>) P.<?> "indentation"
375+
376+-- |
377+-- Check that the current indentation level is at the same indentation as the current mark
378+--
379+same :: P.Parsec String ParseState ()
380+same = checkIndentation (==) P.<?> "no indentation"
381+
382+-- |
383+-- Run a parser which supports indentation
384+--
385+runIndentParser :: FilePath -> P.Parsec String ParseState a -> String -> Either P.ParseError a
386+runIndentParser filePath p = P.runParser p (ParseState 0) filePath
387+
src/Language/PureScript/Parser/Declarations.hsnew file+480
@@ -0,0 +1,480 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.Parser.Declarations
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- Parsers for module definitions and declarations
13+--
14+-----------------------------------------------------------------------------
15+
16+{-# LANGUAGE TupleSections #-}
17+
18+module Language.PureScript.Parser.Declarations (
19+ parseDeclaration,
20+ parseModule,
21+ parseModules,
22+ parseModulesFromFiles,
23+ parseValue,
24+ parseGuard,
25+ parseBinder,
26+ parseBinderNoParens,
27+) where
28+
29+import Data.Maybe (isJust, fromMaybe)
30+import Data.Traversable (forM)
31+
32+import Control.Applicative
33+import Control.Arrow ((+++))
34+
35+import Language.PureScript.Kinds
36+import Language.PureScript.Parser.State
37+import Language.PureScript.Parser.Common
38+import Language.PureScript.AST
39+import Language.PureScript.Parser.Types
40+import Language.PureScript.Parser.Kinds
41+import Language.PureScript.CodeGen.JS.AST
42+import Language.PureScript.Environment
43+
44+import qualified Language.PureScript.Parser.Common as C
45+import qualified Text.Parsec as P
46+import qualified Text.Parsec.Expr as P
47+
48+-- |
49+-- Read source position information
50+--
51+sourcePos :: P.Parsec s u SourcePos
52+sourcePos = toSourcePos <$> P.getPosition
53+ where
54+ toSourcePos p = SourcePos (P.sourceName p) (P.sourceLine p) (P.sourceColumn p)
55+
56+kindedIdent :: P.Parsec String ParseState (String, Maybe Kind)
57+kindedIdent = (, Nothing) <$> identifier
58+ <|> parens ((,) <$> identifier <*> (Just <$> (indented *> lexeme (P.string "::") *> indented *> parseKind)))
59+
60+parseDataDeclaration :: P.Parsec String ParseState Declaration
61+parseDataDeclaration = do
62+ dtype <- (reserved "data" *> return Data) <|> (reserved "newtype" *> return Newtype)
63+ name <- indented *> properName
64+ tyArgs <- many (indented *> kindedIdent)
65+ ctors <- P.option [] $ do
66+ _ <- lexeme $ indented *> P.char '='
67+ sepBy1 ((,) <$> properName <*> P.many (indented *> parseTypeAtom)) pipe
68+ return $ DataDeclaration dtype name tyArgs ctors
69+
70+parseTypeDeclaration :: P.Parsec String ParseState Declaration
71+parseTypeDeclaration =
72+ TypeDeclaration <$> P.try (parseIdent <* lexeme (indented *> P.string "::"))
73+ <*> parsePolyType
74+
75+parseTypeSynonymDeclaration :: P.Parsec String ParseState Declaration
76+parseTypeSynonymDeclaration =
77+ TypeSynonymDeclaration <$> (P.try (reserved "type") *> indented *> properName)
78+ <*> many (indented *> kindedIdent)
79+ <*> (lexeme (indented *> P.char '=') *> parsePolyType)
80+
81+parseValueDeclaration :: P.Parsec String ParseState Declaration
82+parseValueDeclaration = do
83+ name <- parseIdent
84+ binders <- P.many parseBinderNoParens
85+ value <- Left <$> (C.indented *>
86+ C.mark (P.many1 ((,) <$> (C.same *> parseGuard)
87+ <*> (lexeme (indented *> P.char '=') *> parseValueWithWhereClause)
88+ )))
89+ <|> Right <$> (lexeme (indented *> P.char '=') *> parseValueWithWhereClause)
90+ return $ ValueDeclaration name Value binders value
91+ where
92+ parseValueWithWhereClause :: P.Parsec String ParseState Expr
93+ parseValueWithWhereClause = do
94+ value <- parseValue
95+ whereClause <- P.optionMaybe $ do
96+ C.indented
97+ reserved "where"
98+ C.indented
99+ C.mark $ P.many1 (C.same *> parseLocalDeclaration)
100+ return $ maybe value (`Let` value) whereClause
101+
102+parseExternDeclaration :: P.Parsec String ParseState Declaration
103+parseExternDeclaration = P.try (reserved "foreign") *> indented *> reserved "import" *> indented *>
104+ (ExternDataDeclaration <$> (P.try (reserved "data") *> indented *> properName)
105+ <*> (lexeme (indented *> P.string "::") *> parseKind)
106+ <|> (do reserved "instance"
107+ name <- parseIdent <* lexeme (indented *> P.string "::")
108+ deps <- P.option [] $ do
109+ deps <- parens (commaSep1 ((,) <$> parseQualified properName <*> P.many parseTypeAtom))
110+ indented
111+ reservedOp "=>"
112+ return deps
113+ className <- indented *> parseQualified properName
114+ tys <- P.many (indented *> parseTypeAtom)
115+ return $ ExternInstanceDeclaration name deps className tys)
116+ <|> (do ident <- parseIdent
117+ js <- P.optionMaybe (JSRaw <$> stringLiteral)
118+ ty <- lexeme (indented *> P.string "::") *> parsePolyType
119+ return $ ExternDeclaration (if isJust js then InlineJavascript else ForeignImport) ident js ty))
120+
121+parseAssociativity :: P.Parsec String ParseState Associativity
122+parseAssociativity =
123+ (P.try (reserved "infixl") >> return Infixl) <|>
124+ (P.try (reserved "infixr") >> return Infixr) <|>
125+ (P.try (reserved "infix") >> return Infix)
126+
127+parseFixity :: P.Parsec String ParseState Fixity
128+parseFixity = Fixity <$> parseAssociativity <*> (indented *> natural)
129+
130+parseFixityDeclaration :: P.Parsec String ParseState Declaration
131+parseFixityDeclaration = do
132+ fixity <- parseFixity
133+ indented
134+ name <- operator
135+ return $ FixityDeclaration fixity name
136+
137+parseImportDeclaration :: P.Parsec String ParseState Declaration
138+parseImportDeclaration = do
139+ reserved "import"
140+ indented
141+ qualImport <|> stdImport
142+ where
143+ stdImport = do
144+ moduleName' <- moduleName
145+ stdImportHiding moduleName' <|> stdImportQualifying moduleName'
146+ where
147+ stdImportHiding mn = do
148+ reserved "hiding"
149+ declType <- importDeclarationType Hiding
150+ return $ ImportDeclaration mn declType Nothing
151+ stdImportQualifying mn = do
152+ declType <- importDeclarationType Qualifying
153+ return $ ImportDeclaration mn declType Nothing
154+ qualImport = do
155+ reserved "qualified"
156+ indented
157+ moduleName' <- moduleName
158+ declType <- importDeclarationType Qualifying
159+ reserved "as"
160+ asQ <- moduleName
161+ return $ ImportDeclaration moduleName' declType (Just asQ)
162+ importDeclarationType expectedType = do
163+ idents <- P.optionMaybe $ indented *> (parens $ commaSep parseDeclarationRef)
164+ return $ fromMaybe Unqualified (expectedType <$> idents)
165+
166+
167+parseDeclarationRef :: P.Parsec String ParseState DeclarationRef
168+parseDeclarationRef = PositionedDeclarationRef <$> sourcePos <*>
169+ (ValueRef <$> parseIdent
170+ <|> do name <- properName
171+ dctors <- P.optionMaybe $ parens (lexeme (P.string "..") *> pure Nothing <|> Just <$> commaSep properName)
172+ return $ maybe (TypeClassRef name) (TypeRef name) dctors)
173+
174+parseTypeClassDeclaration :: P.Parsec String ParseState Declaration
175+parseTypeClassDeclaration = do
176+ reserved "class"
177+ implies <- P.option [] $ do
178+ indented
179+ implies <- parens (commaSep1 ((,) <$> parseQualified properName <*> P.many parseTypeAtom))
180+ reservedOp "<="
181+ return implies
182+ className <- indented *> properName
183+ idents <- P.many (indented *> kindedIdent)
184+ members <- P.option [] . P.try $ do
185+ indented *> reserved "where"
186+ mark (P.many (same *> positioned parseTypeDeclaration))
187+ return $ TypeClassDeclaration className idents implies members
188+
189+parseTypeInstanceDeclaration :: P.Parsec String ParseState Declaration
190+parseTypeInstanceDeclaration = do
191+ reserved "instance"
192+ name <- parseIdent <* lexeme (indented *> P.string "::")
193+ deps <- P.optionMaybe $ do
194+ deps <- parens (commaSep1 ((,) <$> parseQualified properName <*> P.many parseTypeAtom))
195+ indented
196+ reservedOp "=>"
197+ return deps
198+ className <- indented *> parseQualified properName
199+ ty <- P.many (indented *> parseTypeAtom)
200+ members <- P.option [] . P.try $ do
201+ indented *> reserved "where"
202+ mark (P.many (same *> positioned parseValueDeclaration))
203+ return $ TypeInstanceDeclaration name (fromMaybe [] deps) className ty members
204+
205+positioned :: P.Parsec String ParseState Declaration -> P.Parsec String ParseState Declaration
206+positioned d = PositionedDeclaration <$> sourcePos <*> d
207+
208+-- |
209+-- Parse a single declaration
210+--
211+parseDeclaration :: P.Parsec String ParseState Declaration
212+parseDeclaration = positioned (P.choice
213+ [ parseDataDeclaration
214+ , parseTypeDeclaration
215+ , parseTypeSynonymDeclaration
216+ , parseValueDeclaration
217+ , parseExternDeclaration
218+ , parseFixityDeclaration
219+ , parseImportDeclaration
220+ , parseTypeClassDeclaration
221+ , parseTypeInstanceDeclaration
222+ ]) P.<?> "declaration"
223+
224+parseLocalDeclaration :: P.Parsec String ParseState Declaration
225+parseLocalDeclaration = PositionedDeclaration <$> sourcePos <*> P.choice
226+ [ parseTypeDeclaration
227+ , parseValueDeclaration
228+ ] P.<?> "local declaration"
229+
230+-- |
231+-- Parse a module header and a collection of declarations
232+--
233+parseModule :: P.Parsec String ParseState Module
234+parseModule = do
235+ reserved "module"
236+ indented
237+ name <- moduleName
238+ exports <- P.optionMaybe $ parens $ commaSep1 parseDeclarationRef
239+ _ <- lexeme $ P.string "where"
240+ decls <- mark (P.many (same *> parseDeclaration))
241+ return $ Module name decls exports
242+
243+-- |
244+-- Parse a collection of modules
245+--
246+parseModulesFromFiles :: (k -> String) -> [(k, String)] -> Either P.ParseError [(k, Module)]
247+parseModulesFromFiles toFilePath input =
248+ fmap collect . forM input $ \(filename, content) -> do
249+ ms <- runIndentParser (toFilePath filename) parseModules content
250+ return (filename, ms)
251+ where
252+ collect :: [(k, [v])] -> [(k, v)]
253+ collect vss = [ (k, v) | (k, vs) <- vss, v <- vs ]
254+
255+-- |
256+-- Parse a collection of modules
257+--
258+parseModules :: P.Parsec String ParseState [Module]
259+parseModules = whiteSpace *> mark (P.many (same *> parseModule)) <* P.eof
260+
261+booleanLiteral :: P.Parsec String ParseState Bool
262+booleanLiteral = (C.reserved "true" >> return True) P.<|> (C.reserved "false" >> return False)
263+
264+parseNumericLiteral :: P.Parsec String ParseState Expr
265+parseNumericLiteral = NumericLiteral <$> C.integerOrFloat
266+
267+parseStringLiteral :: P.Parsec String ParseState Expr
268+parseStringLiteral = StringLiteral <$> C.stringLiteral
269+
270+parseBooleanLiteral :: P.Parsec String ParseState Expr
271+parseBooleanLiteral = BooleanLiteral <$> booleanLiteral
272+
273+parseArrayLiteral :: P.Parsec String ParseState Expr
274+parseArrayLiteral = ArrayLiteral <$> C.squares (C.commaSep parseValue)
275+
276+parseObjectLiteral :: P.Parsec String ParseState Expr
277+parseObjectLiteral = ObjectLiteral <$> C.braces (C.commaSep parseIdentifierAndValue)
278+
279+parseIdentifierAndValue :: P.Parsec String ParseState (String, Expr)
280+parseIdentifierAndValue = (,) <$> (C.indented *> (C.identifierName <|> C.stringLiteral) <* C.indented <* C.colon)
281+ <*> (C.indented *> parseValue)
282+
283+parseAbs :: P.Parsec String ParseState Expr
284+parseAbs = do
285+ C.reservedOp "\\"
286+ args <- P.many1 (C.indented *> (Abs <$> (Left <$> P.try C.parseIdent <|> Right <$> parseBinderNoParens)))
287+ C.indented *> C.reservedOp "->"
288+ value <- parseValue
289+ return $ toFunction args value
290+ where
291+ toFunction :: [Expr -> Expr] -> Expr -> Expr
292+ toFunction args value = foldr ($) value args
293+
294+parseVar :: P.Parsec String ParseState Expr
295+parseVar = Var <$> C.parseQualified C.parseIdent
296+
297+parseConstructor :: P.Parsec String ParseState Expr
298+parseConstructor = Constructor <$> C.parseQualified C.properName
299+
300+parseCase :: P.Parsec String ParseState Expr
301+parseCase = Case <$> P.between (P.try (C.reserved "case")) (C.indented *> C.reserved "of") (return <$> parseValue)
302+ <*> (C.indented *> C.mark (P.many (C.same *> C.mark parseCaseAlternative)))
303+
304+parseCaseAlternative :: P.Parsec String ParseState CaseAlternative
305+parseCaseAlternative = CaseAlternative <$> (return <$> parseBinder)
306+ <*> (Left <$> (C.indented *>
307+ C.mark (P.many1 ((,) <$> (C.same *> parseGuard)
308+ <*> (lexeme (indented *> C.reservedOp "->") *> parseValue)
309+ )))
310+ <|> Right <$> (lexeme (indented *> C.reservedOp "->") *> parseValue))
311+ P.<?> "case alternative"
312+
313+parseIfThenElse :: P.Parsec String ParseState Expr
314+parseIfThenElse = IfThenElse <$> (P.try (C.reserved "if") *> C.indented *> parseValue)
315+ <*> (C.indented *> C.reserved "then" *> C.indented *> parseValue)
316+ <*> (C.indented *> C.reserved "else" *> C.indented *> parseValue)
317+
318+parseLet :: P.Parsec String ParseState Expr
319+parseLet = do
320+ C.reserved "let"
321+ C.indented
322+ ds <- C.mark $ P.many1 (C.same *> parseLocalDeclaration)
323+ C.indented
324+ C.reserved "in"
325+ result <- parseValue
326+ return $ Let ds result
327+
328+parseValueAtom :: P.Parsec String ParseState Expr
329+parseValueAtom = P.choice
330+ [ P.try parseNumericLiteral
331+ , P.try parseStringLiteral
332+ , P.try parseBooleanLiteral
333+ , parseArrayLiteral
334+ , P.try parseObjectLiteral
335+ , parseAbs
336+ , P.try parseConstructor
337+ , P.try parseVar
338+ , parseCase
339+ , parseIfThenElse
340+ , parseDo
341+ , parseLet
342+ , Parens <$> C.parens parseValue ]
343+
344+parsePropertyUpdate :: P.Parsec String ParseState (String, Expr)
345+parsePropertyUpdate = do
346+ name <- C.lexeme (C.identifierName <|> C.stringLiteral)
347+ _ <- C.lexeme $ C.indented *> P.char '='
348+ value <- C.indented *> parseValue
349+ return (name, value)
350+
351+parseAccessor :: Expr -> P.Parsec String ParseState Expr
352+parseAccessor (Constructor _) = P.unexpected "constructor"
353+parseAccessor obj = P.try $ Accessor <$> (C.indented *> C.dot *> P.notFollowedBy C.opLetter *> C.indented *> (C.identifierName <|> C.stringLiteral)) <*> pure obj
354+
355+parseDo :: P.Parsec String ParseState Expr
356+parseDo = do
357+ C.reserved "do"
358+ C.indented
359+ Do <$> C.mark (P.many (C.same *> C.mark parseDoNotationElement))
360+
361+parseDoNotationLet :: P.Parsec String ParseState DoNotationElement
362+parseDoNotationLet = DoNotationLet <$> (C.reserved "let" *> C.indented *> C.mark (P.many1 (C.same *> parseLocalDeclaration)))
363+
364+parseDoNotationBind :: P.Parsec String ParseState DoNotationElement
365+parseDoNotationBind = DoNotationBind <$> parseBinder <*> (C.indented *> C.reservedOp "<-" *> parseValue)
366+
367+parseDoNotationElement :: P.Parsec String ParseState DoNotationElement
368+parseDoNotationElement = P.choice
369+ [ P.try parseDoNotationBind
370+ , parseDoNotationLet
371+ , P.try (DoNotationValue <$> parseValue) ]
372+
373+-- |
374+-- Parse a value
375+--
376+parseValue :: P.Parsec String ParseState Expr
377+parseValue = PositionedValue <$> sourcePos <*>
378+ (P.buildExpressionParser operators
379+ . C.buildPostfixParser postfixTable2
380+ $ indexersAndAccessors) P.<?> "expression"
381+ where
382+ indexersAndAccessors = C.buildPostfixParser postfixTable1 parseValueAtom
383+ postfixTable1 = [ parseAccessor
384+ , \v -> P.try $ flip ObjectUpdate <$> (C.indented *> C.braces (C.commaSep1 (C.indented *> parsePropertyUpdate))) <*> pure v ]
385+ postfixTable2 = [ \v -> P.try (flip App <$> (C.indented *> indexersAndAccessors)) <*> pure v
386+ , \v -> flip (TypedValue True) <$> (P.try (C.lexeme (C.indented *> P.string "::")) *> parsePolyType) <*> pure v
387+ ]
388+ operators = [ [ P.Prefix (C.lexeme (P.try (C.indented *> P.char '-') >> return UnaryMinus))
389+ ]
390+ , [ P.Infix (C.lexeme (P.try (C.indented *> C.parseIdentInfix P.<?> "operator") >>= \ident ->
391+ return (BinaryNoParens ident))) P.AssocRight
392+ ]
393+ ]
394+
395+parseStringBinder :: P.Parsec String ParseState Binder
396+parseStringBinder = StringBinder <$> C.stringLiteral
397+
398+parseBooleanBinder :: P.Parsec String ParseState Binder
399+parseBooleanBinder = BooleanBinder <$> booleanLiteral
400+
401+parseNumberBinder :: P.Parsec String ParseState Binder
402+parseNumberBinder = NumberBinder <$> (C.lexeme sign <*> C.integerOrFloat)
403+ where
404+ sign :: P.Parsec String ParseState (Either Integer Double -> Either Integer Double)
405+ sign = (P.char '-' >> return (negate +++ negate))
406+ <|> (P.char '+' >> return id)
407+ <|> return id
408+
409+parseVarBinder :: P.Parsec String ParseState Binder
410+parseVarBinder = VarBinder <$> C.parseIdent
411+
412+parseNullaryConstructorBinder :: P.Parsec String ParseState Binder
413+parseNullaryConstructorBinder = ConstructorBinder <$> C.lexeme (C.parseQualified C.properName) <*> pure []
414+
415+parseConstructorBinder :: P.Parsec String ParseState Binder
416+parseConstructorBinder = ConstructorBinder <$> C.lexeme (C.parseQualified C.properName) <*> many (C.indented *> parseBinderNoParens)
417+
418+parseObjectBinder :: P.Parsec String ParseState Binder
419+parseObjectBinder = ObjectBinder <$> C.braces (C.commaSep (C.indented *> parseIdentifierAndBinder))
420+
421+parseArrayBinder :: P.Parsec String ParseState Binder
422+parseArrayBinder = C.squares $ ArrayBinder <$> C.commaSep (C.indented *> parseBinder)
423+
424+parseNamedBinder :: P.Parsec String ParseState Binder
425+parseNamedBinder = NamedBinder <$> (C.parseIdent <* C.indented <* C.lexeme (P.char '@'))
426+ <*> (C.indented *> parseBinder)
427+
428+parseNullBinder :: P.Parsec String ParseState Binder
429+parseNullBinder = C.lexeme (P.char '_' *> P.notFollowedBy C.identLetter) *> return NullBinder
430+
431+parseIdentifierAndBinder :: P.Parsec String ParseState (String, Binder)
432+parseIdentifierAndBinder = do
433+ name <- C.lexeme (C.identifierName <|> C.stringLiteral)
434+ _ <- C.lexeme $ C.indented *> P.char '='
435+ binder <- C.indented *> parseBinder
436+ return (name, binder)
437+
438+-- |
439+-- Parse a binder
440+--
441+parseBinder :: P.Parsec String ParseState Binder
442+parseBinder = PositionedBinder <$> sourcePos <*>
443+ P.buildExpressionParser operators parseBinderAtom P.<?> "expression"
444+ where
445+ operators = [ [ P.Infix ( C.lexeme (P.try $ C.indented *> C.reservedOp ":") >> return ConsBinder) P.AssocRight ] ]
446+ parseBinderAtom :: P.Parsec String ParseState Binder
447+ parseBinderAtom = P.choice (map P.try
448+ [ parseNullBinder
449+ , parseStringBinder
450+ , parseBooleanBinder
451+ , parseNumberBinder
452+ , parseNamedBinder
453+ , parseVarBinder
454+ , parseConstructorBinder
455+ , parseObjectBinder
456+ , parseArrayBinder
457+ , C.parens parseBinder ]) P.<?> "binder"
458+
459+-- |
460+-- Parse a binder as it would appear in a top level declaration
461+--
462+parseBinderNoParens :: P.Parsec String ParseState Binder
463+parseBinderNoParens = P.choice (map P.try
464+ [ parseNullBinder
465+ , parseStringBinder
466+ , parseBooleanBinder
467+ , parseNumberBinder
468+ , parseNamedBinder
469+ , parseVarBinder
470+ , parseNullaryConstructorBinder
471+ , parseObjectBinder
472+ , parseArrayBinder
473+ , C.parens parseBinder ]) P.<?> "binder"
474+-- |
475+-- Parse a guard
476+--
477+parseGuard :: P.Parsec String ParseState Guard
478+parseGuard = C.pipe *> C.indented *> parseValue
479+
480+
src/Language/PureScript/Parser/Kinds.hsnew file+45
@@ -0,0 +1,45 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.Parser.Kinds
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- A parser for kinds
13+--
14+-----------------------------------------------------------------------------
15+
16+module Language.PureScript.Parser.Kinds (
17+ parseKind
18+) where
19+
20+import Language.PureScript.Kinds
21+import Language.PureScript.Parser.State
22+import Language.PureScript.Parser.Common
23+import Control.Applicative
24+import qualified Text.Parsec as P
25+import qualified Text.Parsec.Expr as P
26+
27+parseStar :: P.Parsec String ParseState Kind
28+parseStar = const Star <$> lexeme (P.char '*')
29+
30+parseBang :: P.Parsec String ParseState Kind
31+parseBang = const Bang <$> lexeme (P.char '!')
32+
33+parseTypeAtom :: P.Parsec String ParseState Kind
34+parseTypeAtom = indented *> P.choice (map P.try
35+ [ parseStar
36+ , parseBang
37+ , parens parseKind ])
38+-- |
39+-- Parse a kind
40+--
41+parseKind :: P.Parsec String ParseState Kind
42+parseKind = P.buildExpressionParser operators parseTypeAtom P.<?> "kind"
43+ where
44+ operators = [ [ P.Prefix (lexeme (P.char '#') >> return Row) ]
45+ , [ P.Infix (lexeme (P.try (P.string "->")) >> return FunKind) P.AssocRight ] ]
src/Language/PureScript/Parser/State.hsnew file+30
@@ -0,0 +1,30 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.Parser.State
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- State for the parser monad
13+--
14+-----------------------------------------------------------------------------
15+
16+module Language.PureScript.Parser.State where
17+
18+import qualified Text.Parsec as P
19+
20+-- |
21+-- State for the parser monad
22+--
23+data ParseState = ParseState {
24+ -- |
25+ -- The most recently marked indentation level
26+ --
27+ indentationLevel :: P.Column
28+ } deriving Show
29+
30+
src/Language/PureScript/Parser/Types.hsnew file+122
@@ -0,0 +1,122 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.Parser.Types
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- Parsers for types
13+--
14+-----------------------------------------------------------------------------
15+
16+module Language.PureScript.Parser.Types (
17+ parseType,
18+ parsePolyType,
19+ parseTypeAtom
20+) where
21+
22+import Control.Applicative
23+import Control.Monad (when, unless)
24+
25+import Language.PureScript.Types
26+import Language.PureScript.Parser.State
27+import Language.PureScript.Parser.Common
28+import Language.PureScript.Parser.Kinds
29+import Language.PureScript.Environment
30+
31+import qualified Text.Parsec as P
32+import qualified Text.Parsec.Expr as P
33+
34+parseArray :: P.Parsec String ParseState Type
35+parseArray = squares $ return tyArray
36+
37+parseArrayOf :: P.Parsec String ParseState Type
38+parseArrayOf = squares $ TypeApp tyArray <$> parseType
39+
40+parseFunction :: P.Parsec String ParseState Type
41+parseFunction = parens $ P.try (lexeme (P.string "->")) >> return tyFunction
42+
43+parseObject :: P.Parsec String ParseState Type
44+parseObject = braces $ TypeApp tyObject <$> parseRow
45+
46+parseTypeWildcard :: P.Parsec String ParseState Type
47+parseTypeWildcard = lexeme (P.char '_') >> return TypeWildcard
48+
49+parseTypeVariable :: P.Parsec String ParseState Type
50+parseTypeVariable = do
51+ ident <- identifier
52+ when (ident `elem` reservedTypeNames) $ P.unexpected ident
53+ return $ TypeVar ident
54+
55+parseTypeConstructor :: P.Parsec String ParseState Type
56+parseTypeConstructor = TypeConstructor <$> parseQualified properName
57+
58+parseForAll :: P.Parsec String ParseState Type
59+parseForAll = mkForAll <$> (P.try (reserved "forall") *> P.many1 (indented *> identifier) <* indented <* dot)
60+ <*> parseConstrainedType
61+
62+-- |
63+-- Parse a type as it appears in e.g. a data constructor
64+--
65+parseTypeAtom :: P.Parsec String ParseState Type
66+parseTypeAtom = indented *> P.choice (map P.try
67+ [ parseArray
68+ , parseArrayOf
69+ , parseFunction
70+ , parseObject
71+ , parseTypeWildcard
72+ , parseTypeVariable
73+ , parseTypeConstructor
74+ , parseForAll
75+ , parens parseRow
76+ , parens parsePolyType ])
77+
78+parseConstrainedType :: P.Parsec String ParseState Type
79+parseConstrainedType = do
80+ constraints <- P.optionMaybe . P.try $ do
81+ constraints <- parens . commaSep1 $ do
82+ className <- parseQualified properName
83+ indented
84+ ty <- P.many parseTypeAtom
85+ return (className, ty)
86+ _ <- lexeme $ P.string "=>"
87+ return constraints
88+ indented
89+ ty <- parseType
90+ return $ maybe ty (flip ConstrainedType ty) constraints
91+
92+parseAnyType :: P.Parsec String ParseState Type
93+parseAnyType = P.buildExpressionParser operators (buildPostfixParser postfixTable parseTypeAtom) P.<?> "type"
94+ where
95+ operators = [ [ P.Infix (return TypeApp) P.AssocLeft ]
96+ , [ P.Infix (P.try (lexeme (P.string "->")) >> return function) P.AssocRight ] ]
97+ postfixTable = [ \t -> KindedType t <$> (P.try (lexeme (indented *> P.string "::")) *> parseKind)
98+ ]
99+
100+-- |
101+-- Parse a monotype
102+--
103+parseType :: P.Parsec String ParseState Type
104+parseType = do
105+ ty <- parseAnyType
106+ unless (isMonoType ty) $ P.unexpected "polymorphic type"
107+ return ty
108+
109+-- |
110+-- Parse a polytype
111+--
112+parsePolyType :: P.Parsec String ParseState Type
113+parsePolyType = parseAnyType
114+
115+parseNameAndType :: P.Parsec String ParseState t -> P.Parsec String ParseState (String, t)
116+parseNameAndType p = (,) <$> (indented *> (identifierName <|> stringLiteral) <* indented <* lexeme (P.string "::")) <*> p
117+
118+parseRowEnding :: P.Parsec String ParseState Type
119+parseRowEnding = P.option REmpty (TypeVar <$> (lexeme (indented *> P.char '|') *> indented *> identifier))
120+
121+parseRow :: P.Parsec String ParseState Type
122+parseRow = (curry rowFromList <$> commaSep (parseNameAndType parsePolyType) <*> parseRowEnding) P.<?> "row"
src/Language/PureScript/Pretty.hsnew file+32
@@ -0,0 +1,32 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.Pretty
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- A collection of pretty printers for core data types:
13+--
14+-- [@Language.PureScript.Pretty.Kinds@] Pretty printer for kinds
15+--
16+-- [@Language.PureScript.Pretty.Values@] Pretty printer for values
17+--
18+-- [@Language.PureScript.Pretty.Types@] Pretty printer for types
19+--
20+-- [@Language.PureScript.Pretty.JS@] Pretty printer for values, used for code generation
21+--
22+-----------------------------------------------------------------------------
23+
24+module Language.PureScript.Pretty (module P) where
25+
26+import Language.PureScript.Pretty.Kinds as P
27+import Language.PureScript.Pretty.Values as P
28+import Language.PureScript.Pretty.Types as P
29+import Language.PureScript.Pretty.JS as P
30+
31+
32+
src/Language/PureScript/Pretty/Common.hsnew file+69
@@ -0,0 +1,69 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.Pretty.Common
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- Common pretty-printing utility functions
13+--
14+-----------------------------------------------------------------------------
15+
16+module Language.PureScript.Pretty.Common where
17+
18+import Control.Monad.State
19+import Data.List (intercalate)
20+import Language.PureScript.Parser.Common (reservedPsNames, opChars)
21+
22+-- |
23+-- Wrap a string in parentheses
24+--
25+parens :: String -> String
26+parens s = ('(':s) ++ ")"
27+
28+newtype PrinterState = PrinterState { indent :: Int } deriving (Show, Eq, Ord)
29+
30+-- |
31+-- Number of characters per identation level
32+--
33+blockIndent :: Int
34+blockIndent = 4
35+
36+-- |
37+-- Pretty print with a new indentation level
38+--
39+withIndent :: StateT PrinterState Maybe String -> StateT PrinterState Maybe String
40+withIndent action = do
41+ modify $ \st -> st { indent = indent st + blockIndent }
42+ result <- action
43+ modify $ \st -> st { indent = indent st - blockIndent }
44+ return result
45+
46+-- |
47+-- Get the current indentation level
48+--
49+currentIndent :: StateT PrinterState Maybe String
50+currentIndent = do
51+ current <- get
52+ return $ replicate (indent current) ' '
53+
54+-- |
55+-- Print many lines
56+--
57+prettyPrintMany :: (a -> StateT PrinterState Maybe String) -> [a] -> StateT PrinterState Maybe String
58+prettyPrintMany f xs = do
59+ ss <- mapM f xs
60+ indentString <- currentIndent
61+ return $ intercalate "\n" $ map (indentString ++) ss
62+
63+-- |
64+-- Prints an object key, escaping reserved names.
65+--
66+prettyPrintObjectKey :: String -> String
67+prettyPrintObjectKey s | s `elem` reservedPsNames = show s
68+ | any (`elem` opChars) s = show s
69+ | otherwise = s
src/Language/PureScript/Pretty/JS.hsnew file+263
@@ -0,0 +1,263 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.Pretty.JS
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- Pretty printer for the Javascript AST
13+--
14+-----------------------------------------------------------------------------
15+
16+module Language.PureScript.Pretty.JS (
17+ prettyPrintJS
18+) where
19+
20+import Language.PureScript.Pretty.Common
21+import Language.PureScript.CodeGen.JS (identNeedsEscaping)
22+import Language.PureScript.CodeGen.JS.AST
23+
24+import Data.List
25+import Data.Maybe (fromMaybe)
26+import qualified Control.Arrow as A
27+import Control.Arrow ((<+>))
28+import Control.PatternArrows
29+import Control.Applicative
30+import Control.Monad.State
31+import Numeric
32+
33+literals :: Pattern PrinterState JS String
34+literals = mkPattern' match
35+ where
36+ match :: JS -> StateT PrinterState Maybe String
37+ match (JSNumericLiteral n) = return $ either show show n
38+ match (JSStringLiteral s) = return $ string s
39+ match (JSBooleanLiteral True) = return "true"
40+ match (JSBooleanLiteral False) = return "false"
41+ match (JSArrayLiteral xs) = fmap concat $ sequence
42+ [ return "[ "
43+ , fmap (intercalate ", ") $ forM xs prettyPrintJS'
44+ , return " ]"
45+ ]
46+ match (JSObjectLiteral []) = return "{}"
47+ match (JSObjectLiteral ps) = fmap concat $ sequence
48+ [ return "{\n"
49+ , withIndent $ do
50+ jss <- forM ps $ \(key, value) -> fmap ((objectPropertyToString key ++ ": ") ++) . prettyPrintJS' $ value
51+ indentString <- currentIndent
52+ return $ intercalate ", \n" $ map (indentString ++) jss
53+ , return "\n"
54+ , currentIndent
55+ , return "}"
56+ ]
57+ where
58+ objectPropertyToString :: String -> String
59+ objectPropertyToString s | identNeedsEscaping s = show s
60+ | otherwise = s
61+ match (JSBlock sts) = fmap concat $ sequence
62+ [ return "{\n"
63+ , withIndent $ prettyStatements sts
64+ , return "\n"
65+ , currentIndent
66+ , return "}"
67+ ]
68+ match (JSVar ident) = return ident
69+ match (JSVariableIntroduction ident value) = fmap concat $ sequence
70+ [ return "var "
71+ , return ident
72+ , maybe (return "") (fmap (" = " ++) . prettyPrintJS') value
73+ ]
74+ match (JSAssignment target value) = fmap concat $ sequence
75+ [ prettyPrintJS' target
76+ , return " = "
77+ , prettyPrintJS' value
78+ ]
79+ match (JSWhile cond sts) = fmap concat $ sequence
80+ [ return "while ("
81+ , prettyPrintJS' cond
82+ , return ") "
83+ , prettyPrintJS' sts
84+ ]
85+ match (JSFor ident start end sts) = fmap concat $ sequence
86+ [ return $ "for (var " ++ ident ++ " = "
87+ , prettyPrintJS' start
88+ , return $ "; " ++ ident ++ " < "
89+ , prettyPrintJS' end
90+ , return $ "; " ++ ident ++ "++) "
91+ , prettyPrintJS' sts
92+ ]
93+ match (JSForIn ident obj sts) = fmap concat $ sequence
94+ [ return $ "for (var " ++ ident ++ " in "
95+ , prettyPrintJS' obj
96+ , return ") "
97+ , prettyPrintJS' sts
98+ ]
99+ match (JSIfElse cond thens elses) = fmap concat $ sequence
100+ [ return "if ("
101+ , prettyPrintJS' cond
102+ , return ") "
103+ , prettyPrintJS' thens
104+ , maybe (return "") (fmap (" else " ++) . prettyPrintJS') elses
105+ ]
106+ match (JSReturn value) = fmap concat $ sequence
107+ [ return "return "
108+ , prettyPrintJS' value
109+ ]
110+ match (JSThrow value) = fmap concat $ sequence
111+ [ return "throw "
112+ , prettyPrintJS' value
113+ ]
114+ match (JSBreak lbl) = return $ "break " ++ lbl
115+ match (JSContinue lbl) = return $ "continue " ++ lbl
116+ match (JSLabel lbl js) = fmap concat $ sequence
117+ [ return $ lbl ++ ": "
118+ , prettyPrintJS' js
119+ ]
120+ match (JSRaw js) = return js
121+ match _ = mzero
122+
123+string :: String -> String
124+string s = '"' : concatMap encodeChar s ++ "\""
125+ where
126+ encodeChar :: Char -> String
127+ encodeChar '\b' = "\\b"
128+ encodeChar '\t' = "\\t"
129+ encodeChar '\n' = "\\n"
130+ encodeChar '\v' = "\\v"
131+ encodeChar '\f' = "\\f"
132+ encodeChar '\r' = "\\r"
133+ encodeChar '"' = "\\\""
134+ encodeChar '\\' = "\\\\"
135+ encodeChar c | fromEnum c > 0xFFF = "\\u" ++ showHex (fromEnum c) ""
136+ encodeChar c | fromEnum c > 0xFF = "\\u0" ++ showHex (fromEnum c) ""
137+ encodeChar c = [c]
138+
139+conditional :: Pattern PrinterState JS ((JS, JS), JS)
140+conditional = mkPattern match
141+ where
142+ match (JSConditional cond th el) = Just ((th, el), cond)
143+ match _ = Nothing
144+
145+accessor :: Pattern PrinterState JS (String, JS)
146+accessor = mkPattern match
147+ where
148+ match (JSAccessor prop val) = Just (prop, val)
149+ match _ = Nothing
150+
151+indexer :: Pattern PrinterState JS (String, JS)
152+indexer = mkPattern' match
153+ where
154+ match (JSIndexer index val) = (,) <$> prettyPrintJS' index <*> pure val
155+ match _ = mzero
156+
157+lam :: Pattern PrinterState JS ((Maybe String, [String]), JS)
158+lam = mkPattern match
159+ where
160+ match (JSFunction name args ret) = Just ((name, args), ret)
161+ match _ = Nothing
162+
163+app :: Pattern PrinterState JS (String, JS)
164+app = mkPattern' match
165+ where
166+ match (JSApp val args) = do
167+ jss <- mapM prettyPrintJS' args
168+ return (intercalate ", " jss, val)
169+ match _ = mzero
170+
171+typeOf :: Pattern PrinterState JS ((), JS)
172+typeOf = mkPattern match
173+ where
174+ match (JSTypeOf val) = Just ((), val)
175+ match _ = Nothing
176+
177+instanceOf :: Pattern PrinterState JS (JS, JS)
178+instanceOf = mkPattern match
179+ where
180+ match (JSInstanceOf val ty) = Just (val, ty)
181+ match _ = Nothing
182+
183+unary :: UnaryOperator -> String -> Operator PrinterState JS String
184+unary op str = Wrap match (++)
185+ where
186+ match :: Pattern PrinterState JS (String, JS)
187+ match = mkPattern match'
188+ where
189+ match' (JSUnary op' val) | op' == op = Just (str, val)
190+ match' _ = Nothing
191+
192+binary :: BinaryOperator -> String -> Operator PrinterState JS String
193+binary op str = AssocL match (\v1 v2 -> v1 ++ " " ++ str ++ " " ++ v2)
194+ where
195+ match :: Pattern PrinterState JS (JS, JS)
196+ match = mkPattern match'
197+ where
198+ match' (JSBinary op' v1 v2) | op' == op = Just (v1, v2)
199+ match' _ = Nothing
200+
201+prettyStatements :: [JS] -> StateT PrinterState Maybe String
202+prettyStatements sts = do
203+ jss <- forM sts prettyPrintJS'
204+ indentString <- currentIndent
205+ return $ intercalate "\n" $ map ((++ ";") . (indentString ++)) jss
206+
207+-- |
208+-- Generate a pretty-printed string representing a Javascript expression
209+--
210+prettyPrintJS1 :: JS -> String
211+prettyPrintJS1 = fromMaybe (error "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyPrintJS'
212+
213+-- |
214+-- Generate a pretty-printed string representing a collection of Javascript expressions at the same indentation level
215+--
216+prettyPrintJS :: [JS] -> String
217+prettyPrintJS = fromMaybe (error "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyStatements
218+
219+-- |
220+-- Generate an indented, pretty-printed string representing a Javascript expression
221+--
222+prettyPrintJS' :: JS -> StateT PrinterState Maybe String
223+prettyPrintJS' = A.runKleisli $ runPattern matchValue
224+ where
225+ matchValue :: Pattern PrinterState JS String
226+ matchValue = buildPrettyPrinter operators (literals <+> fmap parens matchValue)
227+ operators :: OperatorTable PrinterState JS String
228+ operators =
229+ OperatorTable [ [ Wrap accessor $ \prop val -> val ++ "." ++ prop ]
230+ , [ Wrap indexer $ \index val -> val ++ "[" ++ index ++ "]" ]
231+ , [ Wrap app $ \args val -> val ++ "(" ++ args ++ ")" ]
232+ , [ unary JSNew "new " ]
233+ , [ Wrap lam $ \(name, args) ret -> "function "
234+ ++ fromMaybe "" name
235+ ++ "(" ++ intercalate ", " args ++ ") "
236+ ++ ret ]
237+ , [ binary LessThan "<" ]
238+ , [ binary LessThanOrEqualTo "<=" ]
239+ , [ binary GreaterThan ">" ]
240+ , [ binary GreaterThanOrEqualTo ">=" ]
241+ , [ Wrap typeOf $ \_ s -> "typeof " ++ s ]
242+ , [ AssocR instanceOf $ \v1 v2 -> v1 ++ " instanceof " ++ v2 ]
243+ , [ unary Not "!" ]
244+ , [ unary BitwiseNot "~" ]
245+ , [ unary Negate "-" ]
246+ , [ unary Positive "+" ]
247+ , [ binary Multiply "*" ]
248+ , [ binary Divide "/" ]
249+ , [ binary Modulus "%" ]
250+ , [ binary Add "+" ]
251+ , [ binary Subtract "-" ]
252+ , [ binary ShiftLeft "<<" ]
253+ , [ binary ShiftRight ">>" ]
254+ , [ binary ZeroFillShiftRight ">>>" ]
255+ , [ binary EqualTo "===" ]
256+ , [ binary NotEqualTo "!==" ]
257+ , [ binary BitwiseAnd "&" ]
258+ , [ binary BitwiseXor "^" ]
259+ , [ binary BitwiseOr "|" ]
260+ , [ binary And "&&" ]
261+ , [ binary Or "||" ]
262+ , [ Wrap conditional $ \(th, el) cond -> cond ++ " ? " ++ prettyPrintJS1 th ++ " : " ++ prettyPrintJS1 el ]
263+ ]
src/Language/PureScript/Pretty/Kinds.hsnew file+59
@@ -0,0 +1,59 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.Pretty.Kinds
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- Pretty printer for kinds
13+--
14+-----------------------------------------------------------------------------
15+
16+module Language.PureScript.Pretty.Kinds (
17+ prettyPrintKind
18+) where
19+
20+import Data.Maybe (fromMaybe)
21+
22+import Control.Arrow (ArrowPlus(..))
23+import Control.PatternArrows
24+
25+import Language.PureScript.Kinds
26+import Language.PureScript.Pretty.Common
27+
28+typeLiterals :: Pattern () Kind String
29+typeLiterals = mkPattern match
30+ where
31+ match Star = Just "*"
32+ match Bang = Just "!"
33+ match (KUnknown u) = Just $ 'u' : show u
34+ match _ = Nothing
35+
36+matchRow :: Pattern () Kind ((), Kind)
37+matchRow = mkPattern match
38+ where
39+ match (Row k) = Just ((), k)
40+ match _ = Nothing
41+
42+funKind :: Pattern () Kind (Kind, Kind)
43+funKind = mkPattern match
44+ where
45+ match (FunKind arg ret) = Just (arg, ret)
46+ match _ = Nothing
47+
48+-- |
49+-- Generate a pretty-printed string representing a Kind
50+--
51+prettyPrintKind :: Kind -> String
52+prettyPrintKind = fromMaybe (error "Incomplete pattern") . pattern matchKind ()
53+ where
54+ matchKind :: Pattern () Kind String
55+ matchKind = buildPrettyPrinter operators (typeLiterals <+> fmap parens matchKind)
56+ operators :: OperatorTable () Kind String
57+ operators =
58+ OperatorTable [ [ Wrap matchRow $ \_ k -> "# " ++ k]
59+ , [ AssocR funKind $ \arg ret -> arg ++ " -> " ++ ret ] ]
src/Language/PureScript/Pretty/Types.hsnew file+129
@@ -0,0 +1,129 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.Pretty.Types
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- Pretty printer for Types
13+--
14+-----------------------------------------------------------------------------
15+
16+module Language.PureScript.Pretty.Types (
17+ prettyPrintType,
18+ prettyPrintTypeAtom,
19+ prettyPrintRow
20+) where
21+
22+import Data.Maybe (fromMaybe)
23+import Data.List (intercalate)
24+
25+import Control.Arrow ((<+>))
26+import Control.PatternArrows
27+
28+import Language.PureScript.Types
29+import Language.PureScript.Kinds
30+import Language.PureScript.Pretty.Common
31+import Language.PureScript.Pretty.Kinds
32+import Language.PureScript.Environment
33+
34+typeLiterals :: Pattern () Type String
35+typeLiterals = mkPattern match
36+ where
37+ match TypeWildcard = Just "_"
38+ match (TypeVar var) = Just var
39+ match (PrettyPrintObject row) = Just $ "{ " ++ prettyPrintRow row ++ " }"
40+ match (PrettyPrintArray ty) = Just $ "[" ++ prettyPrintType ty ++ "]"
41+ match (TypeConstructor ctor) = Just $ show ctor
42+ match (TUnknown u) = Just $ 'u' : show u
43+ match (Skolem name s _) = Just $ name ++ show s
44+ match (ConstrainedType deps ty) = Just $ "(" ++ intercalate ", " (map (\(pn, ty') -> show pn ++ " " ++ unwords (map prettyPrintTypeAtom ty')) deps) ++ ") => " ++ prettyPrintType ty
45+ match (SaturatedTypeSynonym name args) = Just $ show name ++ "<" ++ intercalate "," (map prettyPrintTypeAtom args) ++ ">"
46+ match REmpty = Just "()"
47+ match row@RCons{} = Just $ '(' : prettyPrintRow row ++ ")"
48+ match _ = Nothing
49+
50+-- |
51+-- Generate a pretty-printed string representing a Row
52+--
53+prettyPrintRow :: Type -> String
54+prettyPrintRow = (\(tys, rest) -> intercalate ", " (map (uncurry nameAndTypeToPs) tys) ++ tailToPs rest) . toList []
55+ where
56+ nameAndTypeToPs :: String -> Type -> String
57+ nameAndTypeToPs name ty = prettyPrintObjectKey name ++ " :: " ++ prettyPrintType ty
58+ tailToPs :: Type -> String
59+ tailToPs REmpty = ""
60+ tailToPs other = " | " ++ prettyPrintType other
61+ toList :: [(String, Type)] -> Type -> ([(String, Type)], Type)
62+ toList tys (RCons name ty row) = toList ((name, ty):tys) row
63+ toList tys r = (tys, r)
64+
65+typeApp :: Pattern () Type (Type, Type)
66+typeApp = mkPattern match
67+ where
68+ match (TypeApp f x) = Just (f, x)
69+ match _ = Nothing
70+
71+appliedFunction :: Pattern () Type (Type, Type)
72+appliedFunction = mkPattern match
73+ where
74+ match (PrettyPrintFunction arg ret) = Just (arg, ret)
75+ match _ = Nothing
76+
77+kinded :: Pattern () Type (Kind, Type)
78+kinded = mkPattern match
79+ where
80+ match (KindedType t k) = Just (k, t)
81+ match _ = Nothing
82+
83+insertPlaceholders :: Type -> Type
84+insertPlaceholders = everywhereOnTypesTopDown convertForAlls . everywhereOnTypes convert
85+ where
86+ convert (TypeApp (TypeApp f arg) ret) | f == tyFunction = PrettyPrintFunction arg ret
87+ convert (TypeApp a el) | a == tyArray = PrettyPrintArray el
88+ convert (TypeApp o r) | o == tyObject = PrettyPrintObject r
89+ convert other = other
90+ convertForAlls (ForAll ident ty _) = go [ident] ty
91+ where
92+ go idents (ForAll ident' ty' _) = go (ident' : idents) ty'
93+ go idents other = PrettyPrintForAll idents other
94+ convertForAlls other = other
95+
96+matchTypeAtom :: Pattern () Type String
97+matchTypeAtom = typeLiterals <+> fmap parens matchType
98+
99+matchType :: Pattern () Type String
100+matchType = buildPrettyPrinter operators matchTypeAtom
101+ where
102+ operators :: OperatorTable () Type String
103+ operators =
104+ OperatorTable [ [ AssocL typeApp $ \f x -> f ++ " " ++ x ]
105+ , [ AssocR appliedFunction $ \arg ret -> arg ++ " -> " ++ ret
106+ ]
107+ , [ Wrap forall_ $ \idents ty -> "forall " ++ unwords idents ++ ". " ++ ty ]
108+ , [ Wrap kinded $ \k ty -> ty ++ " :: " ++ prettyPrintKind k ]
109+ ]
110+
111+forall_ :: Pattern () Type ([String], Type)
112+forall_ = mkPattern match
113+ where
114+ match (PrettyPrintForAll idents ty) = Just (idents, ty)
115+ match _ = Nothing
116+
117+-- |
118+-- Generate a pretty-printed string representing a Type, as it should appear inside parentheses
119+--
120+prettyPrintTypeAtom :: Type -> String
121+prettyPrintTypeAtom = fromMaybe (error "Incomplete pattern") . pattern matchTypeAtom () . insertPlaceholders
122+
123+
124+-- |
125+-- Generate a pretty-printed string representing a Type
126+--
127+prettyPrintType :: Type -> String
128+prettyPrintType = fromMaybe (error "Incomplete pattern") . pattern matchType () . insertPlaceholders
129+
src/Language/PureScript/Pretty/Values.hsnew file+241
@@ -0,0 +1,241 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.Pretty.Values
4+-- Copyright : Kinds.hs(c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- Pretty printer for values
13+--
14+-----------------------------------------------------------------------------
15+
16+module Language.PureScript.Pretty.Values (
17+ prettyPrintValue,
18+ prettyPrintBinder
19+) where
20+
21+import Data.Maybe (fromMaybe)
22+import Data.List (intercalate)
23+
24+import Control.Arrow ((<+>), runKleisli)
25+import Control.PatternArrows
26+import Control.Monad.State
27+import Control.Applicative
28+
29+import Language.PureScript.AST
30+import Language.PureScript.Pretty.Common
31+import Language.PureScript.Pretty.Types (prettyPrintType)
32+
33+literals :: Pattern PrinterState Expr String
34+literals = mkPattern' match
35+ where
36+ match :: Expr -> StateT PrinterState Maybe String
37+ match (NumericLiteral n) = return $ either show show n
38+ match (StringLiteral s) = return $ show s
39+ match (BooleanLiteral True) = return "true"
40+ match (BooleanLiteral False) = return "false"
41+ match (ArrayLiteral xs) = fmap concat $ sequence
42+ [ return "[ "
43+ , withIndent $ prettyPrintMany prettyPrintValue' xs
44+ , return " ]"
45+ ]
46+ match (ObjectLiteral []) = return "{}"
47+ match (ObjectLiteral ps) = fmap concat $ sequence
48+ [ return "{\n"
49+ , withIndent $ prettyPrintMany prettyPrintObjectProperty ps
50+ , return "\n"
51+ , currentIndent
52+ , return "}"
53+ ]
54+ match (TypeClassDictionaryConstructorApp className ps) = fmap concat $ sequence
55+ [ return ((show className) ++ "(\n")
56+ , match ps
57+ , return ")"
58+ ]
59+ match (Constructor name) = return $ show name
60+ match (Case values binders) = fmap concat $ sequence
61+ [ return "case "
62+ , unwords <$> forM values prettyPrintValue'
63+ , return " of\n"
64+ , withIndent $ prettyPrintMany prettyPrintCaseAlternative binders
65+ , currentIndent
66+ ]
67+ match (Let ds val) = fmap concat $ sequence
68+ [ return "let\n"
69+ , withIndent $ prettyPrintMany prettyPrintDeclaration ds
70+ , return "\n"
71+ , currentIndent
72+ , return "in "
73+ , prettyPrintValue' val
74+ ]
75+ match (Var ident) = return $ show ident
76+ match (Do els) = fmap concat $ sequence
77+ [ return "do "
78+ , withIndent $ prettyPrintMany prettyPrintDoNotationElement els
79+ , currentIndent
80+ ]
81+ match (TypeClassDictionary name _ _) = return $ "<<dict " ++ show name ++ ">>"
82+ match (SuperClassDictionary name _) = return $ "<<superclass dict " ++ show name ++ ">>"
83+ match (TypedValue _ val _) = prettyPrintValue' val
84+ match (PositionedValue _ val) = prettyPrintValue' val
85+ match _ = mzero
86+
87+prettyPrintDeclaration :: Declaration -> StateT PrinterState Maybe String
88+prettyPrintDeclaration (TypeDeclaration ident ty) = return $ show ident ++ " :: " ++ prettyPrintType ty
89+prettyPrintDeclaration (ValueDeclaration ident _ [] (Right val)) = fmap concat $ sequence
90+ [ return $ show ident ++ " = "
91+ , prettyPrintValue' val
92+ ]
93+prettyPrintDeclaration (PositionedDeclaration _ d) = prettyPrintDeclaration d
94+prettyPrintDeclaration _ = error "Invalid argument to prettyPrintDeclaration"
95+
96+prettyPrintCaseAlternative :: CaseAlternative -> StateT PrinterState Maybe String
97+prettyPrintCaseAlternative (CaseAlternative binders result) =
98+ fmap concat $ sequence
99+ [ intercalate ", " <$> forM binders prettyPrintBinder'
100+ , prettyPrintResult result
101+ ]
102+ where
103+ prettyPrintResult (Left gs) = concat <$> mapM prettyPrintGuardedValue gs
104+ prettyPrintResult (Right v) = (" -> " ++) <$> prettyPrintValue' v
105+
106+ prettyPrintGuardedValue (grd, val) =
107+ fmap concat $ sequence
108+ [ return "| "
109+ , prettyPrintValue' grd
110+ , return " -> "
111+ , prettyPrintValue' val
112+ , return "\n"
113+ ]
114+
115+prettyPrintDoNotationElement :: DoNotationElement -> StateT PrinterState Maybe String
116+prettyPrintDoNotationElement (DoNotationValue val) =
117+ prettyPrintValue' val
118+prettyPrintDoNotationElement (DoNotationBind binder val) =
119+ fmap concat $ sequence
120+ [ prettyPrintBinder' binder
121+ , return " <- "
122+ , prettyPrintValue' val
123+ ]
124+prettyPrintDoNotationElement (DoNotationLet ds) =
125+ fmap concat $ sequence
126+ [ return "let "
127+ , withIndent $ prettyPrintMany prettyPrintDeclaration ds
128+ ]
129+prettyPrintDoNotationElement (PositionedDoNotationElement _ el) = prettyPrintDoNotationElement el
130+
131+ifThenElse :: Pattern PrinterState Expr ((Expr, Expr), Expr)
132+ifThenElse = mkPattern match
133+ where
134+ match (IfThenElse cond th el) = Just ((th, el), cond)
135+ match _ = Nothing
136+
137+accessor :: Pattern PrinterState Expr (String, Expr)
138+accessor = mkPattern match
139+ where
140+ match (Accessor prop val) = Just (prop, val)
141+ match _ = Nothing
142+
143+objectUpdate :: Pattern PrinterState Expr ([String], Expr)
144+objectUpdate = mkPattern match
145+ where
146+ match (ObjectUpdate o ps) = Just (flip map ps $ \(key, val) -> key ++ " = " ++ prettyPrintValue val, o)
147+ match _ = Nothing
148+
149+app :: Pattern PrinterState Expr (String, Expr)
150+app = mkPattern match
151+ where
152+ match (App val arg) = Just (prettyPrintValue arg, val)
153+ match _ = Nothing
154+
155+lam :: Pattern PrinterState Expr (String, Expr)
156+lam = mkPattern match
157+ where
158+ match (Abs (Left arg) val) = Just (show arg, val)
159+ match _ = Nothing
160+
161+-- |
162+-- Generate a pretty-printed string representing an expression
163+--
164+prettyPrintValue :: Expr -> String
165+prettyPrintValue = fromMaybe (error "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyPrintValue'
166+
167+prettyPrintValue' :: Expr -> StateT PrinterState Maybe String
168+prettyPrintValue' = runKleisli $ runPattern matchValue
169+ where
170+ matchValue :: Pattern PrinterState Expr String
171+ matchValue = buildPrettyPrinter operators (literals <+> fmap parens matchValue)
172+ operators :: OperatorTable PrinterState Expr String
173+ operators =
174+ OperatorTable [ [ Wrap accessor $ \prop val -> val ++ "." ++ prop ]
175+ , [ Wrap objectUpdate $ \ps val -> val ++ "{ " ++ intercalate ", " ps ++ " }" ]
176+ , [ Wrap app $ \arg val -> val ++ "(" ++ arg ++ ")" ]
177+ , [ Split lam $ \arg val -> "\\" ++ arg ++ " -> " ++ prettyPrintValue val ]
178+ , [ Wrap ifThenElse $ \(th, el) cond -> "if " ++ cond ++ " then " ++ prettyPrintValue th ++ " else " ++ prettyPrintValue el ]
179+ ]
180+
181+prettyPrintBinderAtom :: Pattern PrinterState Binder String
182+prettyPrintBinderAtom = mkPattern' match
183+ where
184+ match :: Binder -> StateT PrinterState Maybe String
185+ match NullBinder = return "_"
186+ match (StringBinder str) = return $ show str
187+ match (NumberBinder num) = return $ either show show num
188+ match (BooleanBinder True) = return "true"
189+ match (BooleanBinder False) = return "false"
190+ match (VarBinder ident) = return $ show ident
191+ match (ConstructorBinder ctor args) = fmap concat $ sequence
192+ [ return $ show ctor ++ " "
193+ , unwords <$> forM args match
194+ ]
195+ match (ObjectBinder bs) = fmap concat $ sequence
196+ [ return "{\n"
197+ , withIndent $ prettyPrintMany prettyPrintObjectPropertyBinder bs
198+ , currentIndent
199+ , return "}"
200+ ]
201+ match (ArrayBinder bs) = fmap concat $ sequence
202+ [ return "["
203+ , unwords <$> mapM prettyPrintBinder' bs
204+ , return "]"
205+ ]
206+ match (NamedBinder ident binder) = ((show ident ++ "@") ++) <$> prettyPrintBinder' binder
207+ match (PositionedBinder _ binder) = prettyPrintBinder' binder
208+ match _ = mzero
209+
210+-- |
211+-- Generate a pretty-printed string representing a Binder
212+--
213+prettyPrintBinder :: Binder -> String
214+prettyPrintBinder = fromMaybe (error "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyPrintBinder'
215+
216+prettyPrintBinder' :: Binder -> StateT PrinterState Maybe String
217+prettyPrintBinder' = runKleisli $ runPattern matchBinder
218+ where
219+ matchBinder :: Pattern PrinterState Binder String
220+ matchBinder = buildPrettyPrinter operators (prettyPrintBinderAtom <+> fmap parens matchBinder)
221+ operators :: OperatorTable PrinterState Binder String
222+ operators =
223+ OperatorTable [ [ AssocR matchConsBinder (\b1 b2 -> b1 ++ " : " ++ b2) ] ]
224+
225+matchConsBinder :: Pattern PrinterState Binder (Binder, Binder)
226+matchConsBinder = mkPattern match'
227+ where
228+ match' (ConsBinder b1 b2) = Just (b1, b2)
229+ match' _ = Nothing
230+
231+prettyPrintObjectPropertyBinder :: (String, Binder) -> StateT PrinterState Maybe String
232+prettyPrintObjectPropertyBinder (key, binder) = fmap concat $ sequence
233+ [ return $ prettyPrintObjectKey key ++ ": "
234+ , prettyPrintBinder' binder
235+ ]
236+
237+prettyPrintObjectProperty :: (String, Expr) -> StateT PrinterState Maybe String
238+prettyPrintObjectProperty (key, value) = fmap concat $ sequence
239+ [ return $ prettyPrintObjectKey key ++ ": "
240+ , prettyPrintValue' value
241+ ]
src/Language/PureScript/Renamer.hsnew file+211
@@ -0,0 +1,211 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.Renamer
4+-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- Renaming pass that prevents shadowing of local identifiers.
13+--
14+-----------------------------------------------------------------------------
15+
16+module Language.PureScript.Renamer (renameInModules) where
17+
18+import Control.Applicative
19+import Control.Monad.State
20+
21+import Data.List (find)
22+
23+import qualified Data.Map as M
24+import qualified Data.Set as S
25+
26+import Language.PureScript.AST
27+import Language.PureScript.Environment
28+import Language.PureScript.Names
29+import Language.PureScript.Traversals
30+
31+import qualified Language.PureScript.Constants as C
32+
33+-- |
34+-- The state object used in this module
35+--
36+data RenameState = RenameState {
37+ -- |
38+ -- A map from names bound (in the input) to their names (in the output)
39+ --
40+ rsBoundNames :: M.Map Ident Ident
41+ -- |
42+ -- The set of names which have been used and are in scope in the output
43+ --
44+ , rsUsedNames :: S.Set Ident
45+ }
46+
47+type Rename = State RenameState
48+
49+initState :: [Ident] -> RenameState
50+initState scope = RenameState (M.fromList (zip scope scope)) (S.fromList scope)
51+
52+-- |
53+-- Runs renaming starting with a list of idents for the initial scope.
54+--
55+runRename :: [Ident] -> Rename a -> a
56+runRename scope = flip evalState (initState scope)
57+
58+-- |
59+-- Creates a new renaming scope using the current as a basis. Used to backtrack
60+-- when leaving an Abs.
61+--
62+newScope :: Rename a -> Rename a
63+newScope x = do
64+ scope <- get
65+ a <- x
66+ put scope
67+ return a
68+
69+-- |
70+-- Adds a new scope entry for an ident. If the ident is already present, a new
71+-- unique name is generated and stored.
72+--
73+updateScope :: Ident -> Rename Ident
74+updateScope i@(Ident name) | name == C.__unused = return i
75+updateScope name = do
76+ scope <- get
77+ let name' = case name `S.member` rsUsedNames scope of
78+ True ->
79+ let
80+ newNames = [ Ident (runIdent name ++ "_" ++ show (i :: Int)) | i <- [1..] ]
81+ Just newName = find (`S.notMember` rsUsedNames scope) newNames
82+ in newName
83+ False -> name
84+ modify $ \s -> s { rsBoundNames = M.insert name name' (rsBoundNames s)
85+ , rsUsedNames = S.insert name' (rsUsedNames s)
86+ }
87+ return name'
88+
89+-- |
90+-- Finds the new name to use for an ident.
91+--
92+lookupIdent :: Ident -> Rename Ident
93+lookupIdent i@(Ident name) | name == C.__unused = return i
94+lookupIdent name = do
95+ name' <- gets $ M.lookup name . rsBoundNames
96+ case name' of
97+ Just name'' -> return name''
98+ Nothing -> error $ "Rename scope is missing ident '" ++ show name ++ "'"
99+
100+-- |
101+-- Finds idents introduced by declarations.
102+--
103+findDeclIdents :: [Declaration] -> [Ident]
104+findDeclIdents = concatMap go
105+ where
106+ go (ValueDeclaration ident _ _ _) = [ident]
107+ go (BindingGroupDeclaration ds) = map (\(name, _, _) -> name) ds
108+ go (ExternDeclaration _ ident _ _) = [ident]
109+ go (TypeClassDeclaration _ _ _ ds) = findDeclIdents ds
110+ go (PositionedDeclaration _ d) = go d
111+ go _ = []
112+
113+-- |
114+-- Renames within each declaration in a module.
115+--
116+renameInModules :: [Module] -> [Module]
117+renameInModules = map go
118+ where
119+ go :: Module -> Module
120+ go (Module mn decls exps) = Module mn (renameInDecl' (findDeclIdents decls) `map` decls) exps
121+ renameInDecl' :: [Ident] -> Declaration -> Declaration
122+ renameInDecl' scope = runRename scope . renameInDecl True
123+
124+-- |
125+-- Renames within a declaration. isTopLevel is used to determine whether the
126+-- declaration is a module member or appearing within a Let. At the top level
127+-- declarations are not renamed or added to the scope (they should already have
128+-- been added), whereas in a Let declarations are renamed if their name shadows
129+-- another in the current scope.
130+--
131+renameInDecl :: Bool -> Declaration -> Rename Declaration
132+renameInDecl isTopLevel (ValueDeclaration name nameKind [] (Right val)) = do
133+ name' <- if isTopLevel then return name else updateScope name
134+ ValueDeclaration name' nameKind [] . Right <$> renameInValue val
135+renameInDecl isTopLevel (BindingGroupDeclaration ds) = do
136+ ds' <- mapM updateNames ds
137+ BindingGroupDeclaration <$> mapM updateValues ds'
138+ where
139+ updateNames :: (Ident, NameKind, Expr) -> Rename (Ident, NameKind, Expr)
140+ updateNames (name, nameKind, val) = do
141+ name' <- if isTopLevel then return name else updateScope name
142+ return (name', nameKind, val)
143+ updateValues :: (Ident, NameKind, Expr) -> Rename (Ident, NameKind, Expr)
144+ updateValues (name, nameKind, val) =
145+ (,,) name nameKind <$> renameInValue val
146+renameInDecl _ (TypeInstanceDeclaration name cs className args ds) =
147+ TypeInstanceDeclaration name cs className args <$> mapM (renameInDecl True) ds
148+renameInDecl isTopLevel (PositionedDeclaration pos d) =
149+ PositionedDeclaration pos <$> renameInDecl isTopLevel d
150+renameInDecl _ other = return other
151+
152+-- |
153+-- Renames within a value.
154+--
155+renameInValue :: Expr -> Rename Expr
156+renameInValue (UnaryMinus v) =
157+ UnaryMinus <$> renameInValue v
158+renameInValue (ArrayLiteral vs) =
159+ ArrayLiteral <$> mapM renameInValue vs
160+renameInValue (ObjectLiteral vs) =
161+ ObjectLiteral <$> mapM (\(name, v) -> (,) name <$> renameInValue v) vs
162+renameInValue (Accessor prop v) =
163+ Accessor prop <$> renameInValue v
164+renameInValue (ObjectUpdate obj vs) =
165+ ObjectUpdate <$> renameInValue obj <*> mapM (\(name, v) -> (,) name <$> renameInValue v) vs
166+renameInValue (Abs (Left name) v) =
167+ newScope $ Abs . Left <$> updateScope name <*> renameInValue v
168+renameInValue (App v1 v2) =
169+ App <$> renameInValue v1 <*> renameInValue v2
170+renameInValue (Var (Qualified Nothing name)) =
171+ Var . Qualified Nothing <$> lookupIdent name
172+renameInValue (IfThenElse v1 v2 v3) =
173+ IfThenElse <$> renameInValue v1 <*> renameInValue v2 <*> renameInValue v3
174+renameInValue (Case vs alts) =
175+ newScope $ Case <$> mapM renameInValue vs <*> mapM renameInCaseAlternative alts
176+renameInValue (TypedValue check v ty) =
177+ TypedValue check <$> renameInValue v <*> pure ty
178+renameInValue (Let ds v) =
179+ newScope $ Let <$> mapM (renameInDecl False) ds <*> renameInValue v
180+renameInValue (TypeClassDictionaryConstructorApp name v) =
181+ TypeClassDictionaryConstructorApp name <$> renameInValue v
182+renameInValue (PositionedValue pos v) =
183+ PositionedValue pos <$> renameInValue v
184+renameInValue v = return v
185+
186+-- |
187+-- Renames within case alternatives.
188+--
189+renameInCaseAlternative :: CaseAlternative -> Rename CaseAlternative
190+renameInCaseAlternative (CaseAlternative bs v) =
191+ CaseAlternative <$> mapM renameInBinder bs
192+ <*> eitherM (mapM (pairM renameInValue renameInValue)) renameInValue v
193+
194+-- |
195+-- Renames within binders.
196+--
197+renameInBinder :: Binder -> Rename Binder
198+renameInBinder (VarBinder name) =
199+ VarBinder <$> updateScope name
200+renameInBinder (ConstructorBinder name bs) =
201+ ConstructorBinder name <$> mapM renameInBinder bs
202+renameInBinder (ObjectBinder bs) =
203+ ObjectBinder <$> mapM (sndM renameInBinder) bs
204+renameInBinder (ArrayBinder bs) =
205+ ArrayBinder <$> mapM renameInBinder bs
206+renameInBinder (ConsBinder b1 b2) =
207+ ConsBinder <$> renameInBinder b1 <*> renameInBinder b2
208+renameInBinder (NamedBinder name b) =
209+ NamedBinder <$> updateScope name <*> renameInBinder b
210+renameInBinder (PositionedBinder _ b) = renameInBinder b
211+renameInBinder other = return other
src/Language/PureScript/Sugar.hsnew file+59
@@ -0,0 +1,59 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.Sugar
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- Desugaring passes
13+--
14+-----------------------------------------------------------------------------
15+
16+module Language.PureScript.Sugar (desugar, module S) where
17+
18+import Control.Monad
19+import Control.Category ((>>>))
20+import Control.Monad.Trans.Class
21+
22+import Language.PureScript.AST
23+import Language.PureScript.Errors
24+import Language.PureScript.Supply
25+
26+import Language.PureScript.Sugar.Operators as S
27+import Language.PureScript.Sugar.DoNotation as S
28+import Language.PureScript.Sugar.CaseDeclarations as S
29+import Language.PureScript.Sugar.TypeDeclarations as S
30+import Language.PureScript.Sugar.BindingGroups as S
31+import Language.PureScript.Sugar.TypeClasses as S
32+import Language.PureScript.Sugar.Names as S
33+
34+-- |
35+-- The desugaring pipeline proceeds as follows:
36+--
37+-- * Introduce type synonyms for type class dictionaries
38+--
39+-- * Rebracket user-defined binary operators
40+--
41+-- * Desugar do-notation using the @Prelude.Monad@ type class
42+--
43+-- * Desugar top-level case declarations into explicit case expressions
44+--
45+-- * Desugar type declarations into value declarations with explicit type annotations
46+--
47+-- * Group mutually recursive value and data declarations into binding groups.
48+--
49+-- * Qualify any unqualified names and types
50+--
51+desugar :: [Module] -> SupplyT (Either ErrorStack) [Module]
52+desugar = map removeSignedLiterals
53+ >>> mapM desugarDoModule
54+ >=> desugarCasesModule
55+ >=> lift . (desugarTypeDeclarationsModule
56+ >=> desugarImports
57+ >=> rebracket)
58+ >=> desugarTypeClasses
59+ >=> lift . createBindingGroupsModule
src/Language/PureScript/Sugar/BindingGroups.hsnew file+203
@@ -0,0 +1,203 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.BindingGroups
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- This module implements the desugaring pass which creates binding groups from sets of
13+-- mutually-recursive value declarations and mutually-recursive type declarations.
14+--
15+-----------------------------------------------------------------------------
16+
17+module Language.PureScript.Sugar.BindingGroups (
18+ createBindingGroups,
19+ createBindingGroupsModule,
20+ collapseBindingGroups,
21+ collapseBindingGroupsModule
22+) where
23+
24+import Data.Graph
25+import Data.List (nub, intersect)
26+import Data.Maybe (isJust, mapMaybe)
27+import Data.Monoid ((<>))
28+import Control.Applicative ((<$>), (<*>), pure)
29+
30+import qualified Data.Set as S
31+
32+import Language.PureScript.AST
33+import Language.PureScript.Names
34+import Language.PureScript.Types
35+import Language.PureScript.Environment
36+import Language.PureScript.Errors
37+
38+-- |
39+-- Replace all sets of mutually-recursive declarations in a module with binding groups
40+--
41+createBindingGroupsModule :: [Module] -> Either ErrorStack [Module]
42+createBindingGroupsModule = mapM $ \(Module name ds exps) -> Module name <$> createBindingGroups name ds <*> pure exps
43+
44+-- |
45+-- Collapse all binding groups in a module to individual declarations
46+--
47+collapseBindingGroupsModule :: [Module] -> [Module]
48+collapseBindingGroupsModule = map $ \(Module name ds exps) -> Module name (collapseBindingGroups ds) exps
49+
50+-- |
51+-- Replace all sets of mutually-recursive declarations with binding groups
52+--
53+createBindingGroups :: ModuleName -> [Declaration] -> Either ErrorStack [Declaration]
54+createBindingGroups moduleName ds = do
55+ values <- parU (filter isValueDecl ds) (createBindingGroupsForValue moduleName)
56+ let dataDecls = filter isDataDecl ds
57+ allProperNames = map getProperName dataDecls
58+ dataVerts = map (\d -> (d, getProperName d, usedProperNames moduleName d `intersect` allProperNames)) dataDecls
59+ dataBindingGroupDecls <- parU (stronglyConnComp dataVerts) toDataBindingGroup
60+ let allIdents = map getIdent values
61+ valueVerts = map (\d -> (d, getIdent d, usedIdents moduleName d `intersect` allIdents)) values
62+ bindingGroupDecls <- parU (stronglyConnComp valueVerts) (toBindingGroup moduleName)
63+ return $ filter isImportDecl ds ++
64+ filter isExternDataDecl ds ++
65+ filter isExternInstanceDecl ds ++
66+ dataBindingGroupDecls ++
67+ filter isTypeClassDeclaration ds ++
68+ filter isFixityDecl ds ++
69+ filter isExternDecl ds ++
70+ bindingGroupDecls
71+
72+createBindingGroupsForValue :: ModuleName -> Declaration -> Either ErrorStack Declaration
73+createBindingGroupsForValue moduleName =
74+ let (f, _, _) = everywhereOnValuesTopDownM return go return
75+ in f
76+ where
77+ go (Let ds val) = Let <$> createBindingGroups moduleName ds <*> pure val
78+ go other = return other
79+
80+-- |
81+-- Collapse all binding groups to individual declarations
82+--
83+collapseBindingGroups :: [Declaration] -> [Declaration]
84+collapseBindingGroups = let (f, _, _) = everywhereOnValues id collapseBindingGroupsForValue id in map f . concatMap go
85+ where
86+ go (DataBindingGroupDeclaration ds) = ds
87+ go (BindingGroupDeclaration ds) = map (\(ident, nameKind, val) -> ValueDeclaration ident nameKind [] (Right val)) ds
88+ go (PositionedDeclaration pos d) = map (PositionedDeclaration pos) $ go d
89+ go other = [other]
90+
91+collapseBindingGroupsForValue :: Expr -> Expr
92+collapseBindingGroupsForValue (Let ds val) = Let (collapseBindingGroups ds) val
93+collapseBindingGroupsForValue other = other
94+
95+usedIdents :: ModuleName -> Declaration -> [Ident]
96+usedIdents moduleName =
97+ let (f, _, _, _, _) = everythingWithContextOnValues S.empty [] (++) def usedNamesE usedNamesB def def
98+ in nub . f
99+ where
100+ def s _ = (s, [])
101+
102+ usedNamesE :: S.Set Ident -> Expr -> (S.Set Ident, [Ident])
103+ usedNamesE scope (Var (Qualified Nothing name)) | name `S.notMember` scope = (scope, [name])
104+ usedNamesE scope (Var (Qualified (Just moduleName') name)) | moduleName == moduleName' && name `S.notMember` scope = (scope, [name])
105+ usedNamesE scope (Abs (Left name) _) = (name `S.insert` scope, [])
106+ usedNamesE scope _ = (scope, [])
107+
108+ usedNamesB :: S.Set Ident -> Binder -> (S.Set Ident, [Ident])
109+ usedNamesB scope binder = (scope `S.union` S.fromList (binderNames binder), [])
110+
111+usedImmediateIdents :: ModuleName -> Declaration -> [Ident]
112+usedImmediateIdents moduleName =
113+ let (f, _, _, _, _) = everythingWithContextOnValues True [] (++) def usedNamesE def def def
114+ in nub . f
115+ where
116+ def s _ = (s, [])
117+
118+ usedNamesE :: Bool -> Expr -> (Bool, [Ident])
119+ usedNamesE True (Var (Qualified Nothing name)) = (True, [name])
120+ usedNamesE True (Var (Qualified (Just moduleName') name)) | moduleName == moduleName' = (True, [name])
121+ usedNamesE True (Abs _ _) = (False, [])
122+ usedNamesE scope _ = (scope, [])
123+
124+usedProperNames :: ModuleName -> Declaration -> [ProperName]
125+usedProperNames moduleName =
126+ let (f, _, _, _, _) = accumTypes (everythingOnTypes (++) usedNames)
127+ in nub . f
128+ where
129+ usedNames :: Type -> [ProperName]
130+ usedNames (ConstrainedType constraints _) = flip mapMaybe constraints $ \qual ->
131+ case qual of
132+ (Qualified (Just moduleName') name, _) | moduleName == moduleName' -> Just name
133+ _ -> Nothing
134+ usedNames (TypeConstructor (Qualified (Just moduleName') name)) | moduleName == moduleName' = [name]
135+ usedNames _ = []
136+
137+getIdent :: Declaration -> Ident
138+getIdent (ValueDeclaration ident _ _ _) = ident
139+getIdent (PositionedDeclaration _ d) = getIdent d
140+getIdent _ = error "Expected ValueDeclaration"
141+
142+getProperName :: Declaration -> ProperName
143+getProperName (DataDeclaration _ pn _ _) = pn
144+getProperName (TypeSynonymDeclaration pn _ _) = pn
145+getProperName (PositionedDeclaration _ d) = getProperName d
146+getProperName _ = error "Expected DataDeclaration"
147+
148+-- |
149+-- Convert a group of mutually-recursive dependencies into a BindingGroupDeclaration (or simple ValueDeclaration).
150+--
151+--
152+toBindingGroup :: ModuleName -> SCC Declaration -> Either ErrorStack Declaration
153+toBindingGroup _ (AcyclicSCC d) = return d
154+toBindingGroup _ (CyclicSCC [d]) = return d
155+toBindingGroup moduleName (CyclicSCC ds') =
156+ -- Once we have a mutually-recursive group of declarations, we need to sort
157+ -- them further by their immediate dependencies (those outside function
158+ -- bodies). In particular, this is relevant for type instance dictionaries
159+ -- whose members require other type instances (for example, functorEff
160+ -- defines (<$>) = liftA1, which depends on applicativeEff). Note that
161+ -- superclass references are still inside functions, so don't count here.
162+ -- If we discover declarations that still contain mutually-recursive
163+ -- immediate references, we're guaranteed to get an undefined reference at
164+ -- runtime, so treat this as an error. See also github issue #365.
165+ BindingGroupDeclaration <$> mapM toBinding (stronglyConnComp valueVerts)
166+ where
167+ idents :: [Ident]
168+ idents = map (\(_, i, _) -> i) valueVerts
169+
170+ valueVerts :: [(Declaration, Ident, [Ident])]
171+ valueVerts = map (\d -> (d, getIdent d, usedImmediateIdents moduleName d `intersect` idents)) ds'
172+
173+ toBinding :: SCC Declaration -> Either ErrorStack (Ident, NameKind, Expr)
174+ toBinding (AcyclicSCC d) = return $ fromValueDecl d
175+ toBinding (CyclicSCC ~(d:ds)) = cycleError d ds
176+
177+ cycleError :: Declaration -> [Declaration] -> Either ErrorStack a
178+ cycleError (PositionedDeclaration p d) ds = rethrowWithPosition p $ cycleError d ds
179+ cycleError (ValueDeclaration n _ _ (Right e)) [] = Left $
180+ mkErrorStack ("Cycle in definition of " ++ show n) (Just (ExprError e))
181+ cycleError d ds@(_:_) = rethrow (<> mkErrorStack ("The following are not yet defined here: " ++ unwords (map (show . getIdent) ds)) Nothing) $ cycleError d []
182+ cycleError _ _ = error "Expected ValueDeclaration"
183+
184+
185+toDataBindingGroup :: SCC Declaration -> Either ErrorStack Declaration
186+toDataBindingGroup (AcyclicSCC d) = return d
187+toDataBindingGroup (CyclicSCC [d]) = case isTypeSynonym d of
188+ Just pn -> Left $ mkErrorStack ("Cycle in type synonym " ++ show pn) Nothing
189+ _ -> return d
190+toDataBindingGroup (CyclicSCC ds')
191+ | all (isJust . isTypeSynonym) ds' = Left $ mkErrorStack "Cycle in type synonyms" Nothing
192+ | otherwise = return $ DataBindingGroupDeclaration ds'
193+
194+isTypeSynonym :: Declaration -> Maybe ProperName
195+isTypeSynonym (TypeSynonymDeclaration pn _ _) = Just pn
196+isTypeSynonym (PositionedDeclaration _ d) = isTypeSynonym d
197+isTypeSynonym _ = Nothing
198+
199+fromValueDecl :: Declaration -> (Ident, NameKind, Expr)
200+fromValueDecl (ValueDeclaration ident nameKind [] (Right val)) = (ident, nameKind, val)
201+fromValueDecl ValueDeclaration{} = error "Binders should have been desugared"
202+fromValueDecl (PositionedDeclaration _ d) = fromValueDecl d
203+fromValueDecl _ = error "Expected ValueDeclaration"
src/Language/PureScript/Sugar/CaseDeclarations.hsnew file+123
@@ -0,0 +1,123 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.CaseDeclarations
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- This module implements the desugaring pass which replaces top-level binders with
13+-- case expressions.
14+--
15+-----------------------------------------------------------------------------
16+
17+module Language.PureScript.Sugar.CaseDeclarations (
18+ desugarCases,
19+ desugarCasesModule
20+) where
21+
22+import Data.Either (isLeft)
23+import Data.Monoid ((<>))
24+import Data.List (nub, groupBy)
25+
26+import Control.Applicative
27+import Control.Monad ((<=<), forM, join, unless, replicateM)
28+import Control.Monad.Error.Class
29+
30+import Language.PureScript.Names
31+import Language.PureScript.AST
32+import Language.PureScript.Environment
33+import Language.PureScript.Errors
34+import Language.PureScript.Supply
35+import Language.PureScript.Traversals
36+import Language.PureScript.TypeChecker.Monad (guardWith)
37+
38+-- |
39+-- Replace all top-level binders in a module with case expressions.
40+--
41+desugarCasesModule :: [Module] -> SupplyT (Either ErrorStack) [Module]
42+desugarCasesModule ms = forM ms $ \(Module name ds exps) ->
43+ rethrow (strMsg ("Error in module " ++ show name) <>) $
44+ Module name <$> (desugarCases <=< desugarAbs $ ds) <*> pure exps
45+
46+desugarAbs :: [Declaration] -> SupplyT (Either ErrorStack) [Declaration]
47+desugarAbs = flip parU f
48+ where
49+ (f, _, _) = everywhereOnValuesM return replace return
50+
51+ replace :: Expr -> SupplyT (Either ErrorStack) Expr
52+ replace (Abs (Right binder) val) = do
53+ ident <- Ident <$> freshName
54+ return $ Abs (Left ident) $ Case [Var (Qualified Nothing ident)] [CaseAlternative [binder] (Right val)]
55+ replace other = return other
56+
57+-- |
58+-- Replace all top-level binders with case expressions.
59+--
60+desugarCases :: [Declaration] -> SupplyT (Either ErrorStack) [Declaration]
61+desugarCases = desugarRest <=< fmap join . flip parU toDecls . groupBy inSameGroup
62+ where
63+ desugarRest :: [Declaration] -> SupplyT (Either ErrorStack) [Declaration]
64+ desugarRest (TypeInstanceDeclaration name constraints className tys ds : rest) =
65+ (:) <$> (TypeInstanceDeclaration name constraints className tys <$> desugarCases ds) <*> desugarRest rest
66+ desugarRest (ValueDeclaration name nameKind bs result : rest) =
67+ let (_, f, _) = everywhereOnValuesTopDownM return go return
68+ f' (Left gs) = Left <$> mapM (pairM return f) gs
69+ f' (Right v) = Right <$> f v
70+ in (:) <$> (ValueDeclaration name nameKind bs <$> f' result) <*> desugarRest rest
71+ where
72+ go (Let ds val') = Let <$> desugarCases ds <*> pure val'
73+ go other = return other
74+ desugarRest (PositionedDeclaration pos d : ds) = do
75+ (d' : ds') <- desugarRest (d : ds)
76+ return (PositionedDeclaration pos d' : ds')
77+ desugarRest (d : ds) = (:) d <$> desugarRest ds
78+ desugarRest [] = pure []
79+
80+inSameGroup :: Declaration -> Declaration -> Bool
81+inSameGroup (ValueDeclaration ident1 _ _ _) (ValueDeclaration ident2 _ _ _) = ident1 == ident2
82+inSameGroup (PositionedDeclaration _ d1) d2 = inSameGroup d1 d2
83+inSameGroup d1 (PositionedDeclaration _ d2) = inSameGroup d1 d2
84+inSameGroup _ _ = False
85+
86+toDecls :: [Declaration] -> SupplyT (Either ErrorStack) [Declaration]
87+toDecls [ValueDeclaration ident nameKind bs (Right val)] | all isVarBinder bs = do
88+ let args = map (\(VarBinder arg) -> arg) bs
89+ body = foldr (Abs . Left) val args
90+ guardWith (strMsg "Overlapping function argument names") $ length (nub args) == length args
91+ return [ValueDeclaration ident nameKind [] (Right body)]
92+toDecls ds@(ValueDeclaration ident _ bs result : _) = do
93+ let tuples = map toTuple ds
94+ unless (all ((== length bs) . length . fst) tuples) $
95+ throwError $ mkErrorStack ("Argument list lengths differ in declaration " ++ show ident) Nothing
96+ unless (not (null bs) || isLeft result) $
97+ throwError $ mkErrorStack ("Duplicate value declaration '" ++ show ident ++ "'") Nothing
98+ caseDecl <- makeCaseDeclaration ident tuples
99+ return [caseDecl]
100+toDecls (PositionedDeclaration pos d : ds) = do
101+ (d' : ds') <- rethrowWithPosition pos $ toDecls (d : ds)
102+ return (PositionedDeclaration pos d' : ds')
103+toDecls ds = return ds
104+
105+isVarBinder :: Binder -> Bool
106+isVarBinder (VarBinder _) = True
107+isVarBinder _ = False
108+
109+toTuple :: Declaration -> ([Binder], Either [(Guard, Expr)] Expr)
110+toTuple (ValueDeclaration _ _ bs result) = (bs, result)
111+toTuple (PositionedDeclaration _ d) = toTuple d
112+toTuple _ = error "Not a value declaration"
113+
114+makeCaseDeclaration :: Ident -> [([Binder], Either [(Guard, Expr)] Expr)] -> SupplyT (Either ErrorStack) Declaration
115+makeCaseDeclaration ident alternatives = do
116+ let argPattern = length . fst . head $ alternatives
117+ args <- map Ident <$> replicateM argPattern freshName
118+ let
119+ vars = map (Var . Qualified Nothing) args
120+ binders = [ CaseAlternative bs result | (bs, result) <- alternatives ]
121+ value = foldr (Abs . Left) (Case vars binders) args
122+ return $ ValueDeclaration ident Value [] (Right value)
123+
src/Language/PureScript/Sugar/DoNotation.hsnew file+74
@@ -0,0 +1,74 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.Sugar.DoNotation
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- This module implements the desugaring pass which replaces do-notation statements with
13+-- appropriate calls to (>>=) from the Prelude.Monad type class.
14+--
15+-----------------------------------------------------------------------------
16+
17+module Language.PureScript.Sugar.DoNotation (
18+ desugarDoModule
19+) where
20+
21+import Language.PureScript.Names
22+import Language.PureScript.AST
23+import Language.PureScript.Errors
24+import Language.PureScript.Supply
25+
26+import qualified Language.PureScript.Constants as C
27+
28+import Control.Applicative
29+import Control.Monad.Trans.Class
30+
31+-- |
32+-- Replace all @DoNotationBind@ and @DoNotationValue@ constructors with applications of the Prelude.(>>=) function,
33+-- and all @DoNotationLet@ constructors with let expressions.
34+--
35+desugarDoModule :: Module -> SupplyT (Either ErrorStack) Module
36+desugarDoModule (Module mn ds exts) = Module mn <$> parU ds desugarDo <*> pure exts
37+
38+desugarDo :: Declaration -> SupplyT (Either ErrorStack) Declaration
39+desugarDo (PositionedDeclaration pos d) = (PositionedDeclaration pos) <$> (rethrowWithPosition pos $ desugarDo d)
40+desugarDo d =
41+ let (f, _, _) = everywhereOnValuesM return replace return
42+ in f d
43+ where
44+ prelude :: ModuleName
45+ prelude = ModuleName [ProperName C.prelude]
46+
47+ bind :: Expr
48+ bind = Var (Qualified (Just prelude) (Op (C.>>=)))
49+
50+ replace :: Expr -> SupplyT (Either ErrorStack) Expr
51+ replace (Do els) = go els
52+ replace (PositionedValue pos v) = PositionedValue pos <$> rethrowWithPosition pos (replace v)
53+ replace other = return other
54+
55+ go :: [DoNotationElement] -> SupplyT (Either ErrorStack) Expr
56+ go [] = error "The impossible happened in desugarDo"
57+ go [DoNotationValue val] = return val
58+ go (DoNotationValue val : rest) = do
59+ rest' <- go rest
60+ return $ App (App bind val) (Abs (Left (Ident C.__unused)) rest')
61+ go [DoNotationBind _ _] = lift $ Left $ mkErrorStack "Bind statement cannot be the last statement in a do block" Nothing
62+ go (DoNotationBind NullBinder val : rest) = go (DoNotationValue val : rest)
63+ go (DoNotationBind (VarBinder ident) val : rest) = do
64+ rest' <- go rest
65+ return $ App (App bind val) (Abs (Left ident) rest')
66+ go (DoNotationBind binder val : rest) = do
67+ rest' <- go rest
68+ ident <- Ident <$> freshName
69+ return $ App (App bind val) (Abs (Left ident) (Case [Var (Qualified Nothing ident)] [CaseAlternative [binder] (Right rest')]))
70+ go [DoNotationLet _] = lift $ Left $ mkErrorStack "Let statement cannot be the last statement in a do block" Nothing
71+ go (DoNotationLet ds : rest) = do
72+ rest' <- go rest
73+ return $ Let ds rest'
74+ go (PositionedDoNotationElement pos el : rest) = rethrowWithPosition pos $ PositionedValue pos <$> go (el : rest)
src/Language/PureScript/Sugar/Names.hsnew file+522
@@ -0,0 +1,522 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.Sugar.Names
4+-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+--
13+-----------------------------------------------------------------------------
14+
15+module Language.PureScript.Sugar.Names (
16+ desugarImports
17+) where
18+
19+import Data.List (nub)
20+import Data.Maybe (fromMaybe, isJust, mapMaybe)
21+import Data.Monoid ((<>))
22+
23+import Control.Applicative (Applicative(..), (<$>), (<*>))
24+import Control.Monad.Error
25+
26+import qualified Data.Map as M
27+
28+import Language.PureScript.AST
29+import Language.PureScript.Names
30+import Language.PureScript.Types
31+import Language.PureScript.Environment
32+import Language.PureScript.Errors
33+import Language.PureScript.Traversals
34+
35+import qualified Language.PureScript.Constants as C
36+
37+-- |
38+-- The global export environment - every declaration exported from every module.
39+--
40+type ExportEnvironment = M.Map ModuleName Exports
41+
42+-- |
43+-- The exported declarations from a module.
44+--
45+data Exports = Exports
46+ {
47+ -- |
48+ -- The types exported from each module
49+ --
50+ exportedTypes :: [(ProperName, [ProperName])]
51+ -- |
52+ -- The classes exported from each module
53+ --
54+ , exportedTypeClasses :: [ProperName]
55+ -- |
56+ -- The values exported from each module
57+ , exportedValues :: [Ident]
58+ --
59+ } deriving (Show)
60+
61+-- |
62+-- An imported environment for a particular module. This also contains the module's own members.
63+--
64+data ImportEnvironment = ImportEnvironment
65+ {
66+ -- |
67+ -- Local names for types within a module mapped to to their qualified names
68+ --
69+ importedTypes :: M.Map (Qualified ProperName) (Qualified ProperName)
70+ -- |
71+ -- Local names for data constructors within a module mapped to to their qualified names
72+ --
73+ , importedDataConstructors :: M.Map (Qualified ProperName) (Qualified ProperName)
74+ -- |
75+ -- Local names for classes within a module mapped to to their qualified names
76+ --
77+ , importedTypeClasses :: M.Map (Qualified ProperName) (Qualified ProperName)
78+ -- |
79+ -- Local names for values within a module mapped to to their qualified names
80+ --
81+ , importedValues :: M.Map (Qualified Ident) (Qualified Ident)
82+ } deriving (Show)
83+
84+-- |
85+-- Updates the exports for a module from the global environment. If the module was not previously
86+-- present in the global environment, it is created.
87+--
88+updateExportedModule :: ExportEnvironment -> ModuleName -> (Exports -> Either ErrorStack Exports) -> Either ErrorStack ExportEnvironment
89+updateExportedModule env mn update = do
90+ let exports = fromMaybe (error "Module was undefined in updateExportedModule") $ mn `M.lookup` env
91+ exports' <- update exports
92+ return $ M.insert mn exports' env
93+
94+-- |
95+-- Adds an empty module to an ExportEnvironment.
96+--
97+addEmptyModule :: ExportEnvironment -> ModuleName -> Either ErrorStack ExportEnvironment
98+addEmptyModule env name =
99+ if name `M.member` env
100+ then throwError $ mkErrorStack ("Module '" ++ show name ++ "' has been defined more than once") Nothing
101+ else return $ M.insert name (Exports [] [] []) env
102+
103+-- |
104+-- Adds a type belonging to a module to the export environment.
105+--
106+addType :: ExportEnvironment -> ModuleName -> ProperName -> [ProperName] -> Either ErrorStack ExportEnvironment
107+addType env mn name dctors = updateExportedModule env mn $ \m -> do
108+ types' <- addExport (exportedTypes m) (name, dctors)
109+ return $ m { exportedTypes = types' }
110+
111+-- |
112+-- Adds a class to the export environment.
113+--
114+addTypeClass :: ExportEnvironment -> ModuleName -> ProperName -> Either ErrorStack ExportEnvironment
115+addTypeClass env mn name = updateExportedModule env mn $ \m -> do
116+ classes <- addExport (exportedTypeClasses m) name
117+ return $ m { exportedTypeClasses = classes }
118+
119+-- |
120+-- Adds a class to the export environment.
121+--
122+addValue :: ExportEnvironment -> ModuleName -> Ident -> Either ErrorStack ExportEnvironment
123+addValue env mn name = updateExportedModule env mn $ \m -> do
124+ values <- addExport (exportedValues m) name
125+ return $ m { exportedValues = values }
126+
127+-- |
128+-- Adds an entry to a list of exports unless it is already present, in which case an error is
129+-- returned.
130+--
131+addExport :: (Eq a, Show a) => [a] -> a -> Either ErrorStack [a]
132+addExport exports name =
133+ if name `elem` exports
134+ then throwError $ mkErrorStack ("Multiple definitions for '" ++ show name ++ "'") Nothing
135+ else return $ name : exports
136+
137+-- |
138+-- Replaces all local names with qualified names within a set of modules.
139+--
140+desugarImports :: [Module] -> Either ErrorStack [Module]
141+desugarImports modules = do
142+ unfilteredExports <- findExports modules
143+ exports <- foldM filterModuleExports unfilteredExports modules
144+ mapM (renameInModule' unfilteredExports exports) modules
145+ where
146+
147+ -- Filters the exports for a module in the global exports environment so that only explicitly
148+ -- exported members remain. If the module does not explicitly export anything, everything is
149+ -- exported.
150+ filterModuleExports :: ExportEnvironment -> Module -> Either ErrorStack ExportEnvironment
151+ filterModuleExports env (Module mn _ (Just exps)) = filterExports mn exps env
152+ filterModuleExports env _ = return env
153+
154+ -- Rename and check all the names within a module. We tweak the global exports environment so
155+ -- the module has access to an unfiltered list of its own members.
156+ renameInModule' :: ExportEnvironment -> ExportEnvironment -> Module -> Either ErrorStack Module
157+ renameInModule' unfilteredExports exports m@(Module mn _ _) =
158+ rethrow (strMsg ("Error in module " ++ show mn) <>) $ do
159+ let env = M.update (\_ -> M.lookup mn unfilteredExports) mn exports
160+ let exps = fromMaybe (error "Module is missing in renameInModule'") $ M.lookup mn exports
161+ imports <- resolveImports env m
162+ elaborateImports <$> renameInModule imports env (elaborateExports exps m)
163+
164+-- |
165+-- Make all exports for a module explicit. This may still effect modules that have an exports list,
166+-- as it will also make all data constructor exports explicit.
167+--
168+elaborateExports :: Exports -> Module -> Module
169+elaborateExports exps (Module mn decls _) = Module mn decls (Just $
170+ map (\(ctor, dctors) -> TypeRef ctor (Just dctors)) (exportedTypes exps) ++
171+ map TypeClassRef (exportedTypeClasses exps) ++
172+ map ValueRef (exportedValues exps))
173+
174+-- |
175+-- Add `import X ()` for any modules where there are only fully qualified references to members.
176+-- This ensures transitive instances are included when using a member from a module.
177+--
178+elaborateImports :: Module -> Module
179+elaborateImports (Module mn decls exps) = Module mn decls' exps
180+ where
181+ decls' :: [Declaration]
182+ decls' =
183+ let (f, _, _, _, _) = everythingOnValues (++) (const []) fqValues (const []) (const []) (const [])
184+ in mkImport `map` nub (f `concatMap` decls) ++ decls
185+ fqValues :: Expr -> [ModuleName]
186+ fqValues (Var (Qualified (Just mn') _)) = [mn']
187+ fqValues _ = []
188+ mkImport :: ModuleName -> Declaration
189+ mkImport mn' = ImportDeclaration mn' (Qualifying []) Nothing
190+
191+-- |
192+-- Replaces all local names with qualified names within a module and checks that all existing
193+-- qualified names are valid.
194+--
195+renameInModule :: ImportEnvironment -> ExportEnvironment -> Module -> Either ErrorStack Module
196+renameInModule imports exports (Module mn decls exps) =
197+ Module mn <$> parU decls go <*> pure exps
198+ where
199+ (go, _, _, _, _) = everywhereWithContextOnValuesM (Nothing, []) updateDecl updateValue updateBinder updateCase defS
200+
201+ updateDecl :: (Maybe SourcePos, [Ident]) -> Declaration -> Either ErrorStack ((Maybe SourcePos, [Ident]), Declaration)
202+ updateDecl (_, bound) d@(PositionedDeclaration pos _) = return ((Just pos, bound), d)
203+ updateDecl (pos, bound) (DataDeclaration dtype name args dctors) =
204+ (,) (pos, bound) <$> (DataDeclaration dtype name args <$> mapM (sndM (mapM (updateTypesEverywhere pos))) dctors)
205+ updateDecl (pos, bound) (TypeSynonymDeclaration name ps ty) =
206+ (,) (pos, bound) <$> (TypeSynonymDeclaration name ps <$> updateTypesEverywhere pos ty)
207+ updateDecl (pos, bound) (TypeClassDeclaration className args implies ds) =
208+ (,) (pos, bound) <$> (TypeClassDeclaration className args <$> updateConstraints pos implies <*> pure ds)
209+ updateDecl (pos, bound) (TypeInstanceDeclaration name cs cn ts ds) =
210+ (,) (pos, bound) <$> (TypeInstanceDeclaration name <$> updateConstraints pos cs <*> updateClassName cn pos <*> mapM (updateTypesEverywhere pos) ts <*> pure ds)
211+ updateDecl (pos, bound) (ExternInstanceDeclaration name cs cn ts) =
212+ (,) (pos, bound) <$> (ExternInstanceDeclaration name <$> updateConstraints pos cs <*> updateClassName cn Nothing <*> mapM (updateTypesEverywhere pos) ts)
213+ updateDecl (pos, bound) (TypeDeclaration name ty) =
214+ (,) (pos, bound) <$> (TypeDeclaration name <$> updateTypesEverywhere pos ty)
215+ updateDecl (pos, bound) (ExternDeclaration fit name js ty) =
216+ (,) (pos, name : bound) <$> (ExternDeclaration fit name js <$> updateTypesEverywhere pos ty)
217+ updateDecl s d = return (s, d)
218+
219+ updateValue :: (Maybe SourcePos, [Ident]) -> Expr -> Either ErrorStack ((Maybe SourcePos, [Ident]), Expr)
220+ updateValue (_, bound) v@(PositionedValue pos' _) = return ((Just pos', bound), v)
221+ updateValue (pos, bound) (Abs (Left arg) val') = return ((pos, arg : bound), Abs (Left arg) val')
222+ updateValue (pos, bound) (Let ds val') =
223+ let args = mapMaybe letBoundVariable ds
224+ in return ((pos, args ++ bound), Let ds val')
225+ updateValue (pos, bound) (Var name'@(Qualified Nothing ident)) | ident `notElem` bound =
226+ (,) (pos, bound) <$> (Var <$> updateValueName name' pos)
227+ updateValue (pos, bound) (Var name'@(Qualified (Just _) _)) =
228+ (,) (pos, bound) <$> (Var <$> updateValueName name' pos)
229+ updateValue (pos, bound) (BinaryNoParens name'@(Qualified Nothing ident) v1 v2) | ident `notElem` bound =
230+ (,) (pos, bound) <$> (BinaryNoParens <$> updateValueName name' pos <*> pure v1 <*> pure v2)
231+ updateValue (pos, bound) (BinaryNoParens name'@(Qualified (Just _) _) v1 v2) =
232+ (,) (pos, bound) <$> (BinaryNoParens <$> updateValueName name' pos <*> pure v1 <*> pure v2)
233+ updateValue s@(pos, _) (Constructor name) = (,) s <$> (Constructor <$> updateDataConstructorName name pos)
234+ updateValue s@(pos, _) (TypedValue check val ty) = (,) s <$> (TypedValue check val <$> updateTypesEverywhere pos ty)
235+ updateValue s v = return (s, v)
236+
237+ updateBinder :: (Maybe SourcePos, [Ident]) -> Binder -> Either ErrorStack ((Maybe SourcePos, [Ident]), Binder)
238+ updateBinder (_, bound) v@(PositionedBinder pos _) = return ((Just pos, bound), v)
239+ updateBinder s@(pos, _) (ConstructorBinder name b) = (,) s <$> (ConstructorBinder <$> updateDataConstructorName name pos <*> pure b)
240+ updateBinder s v = return (s, v)
241+
242+ updateCase :: (Maybe SourcePos, [Ident]) -> CaseAlternative -> Either ErrorStack ((Maybe SourcePos, [Ident]), CaseAlternative)
243+ updateCase (pos, bound) c@(CaseAlternative bs _) = return ((pos, concatMap binderNames bs ++ bound), c)
244+
245+ letBoundVariable :: Declaration -> Maybe Ident
246+ letBoundVariable (ValueDeclaration ident _ _ _) = Just ident
247+ letBoundVariable (PositionedDeclaration _ d) = letBoundVariable d
248+ letBoundVariable _ = Nothing
249+
250+ updateTypesEverywhere :: Maybe SourcePos -> Type -> Either ErrorStack Type
251+ updateTypesEverywhere pos0 = everywhereOnTypesM (updateType pos0)
252+ where
253+ updateType :: Maybe SourcePos -> Type -> Either ErrorStack Type
254+ updateType pos (TypeConstructor name) = TypeConstructor <$> updateTypeName name pos
255+ updateType pos (SaturatedTypeSynonym name tys) = SaturatedTypeSynonym <$> updateTypeName name pos <*> pure tys
256+ updateType pos (ConstrainedType cs t) = ConstrainedType <$> updateConstraints pos cs <*> pure t
257+ updateType _ t = return t
258+
259+ updateConstraints pos = mapM (\(name, ts) -> (,) <$> updateClassName name pos <*> mapM (updateTypesEverywhere pos) ts)
260+
261+ updateTypeName = update "type" importedTypes (\mes -> isJust . (`lookup` exportedTypes mes))
262+ updateClassName = update "type class" importedTypeClasses (flip elem . exportedTypeClasses)
263+ updateValueName = update "value" importedValues (flip elem . exportedValues)
264+ updateDataConstructorName = update "data constructor" importedDataConstructors (\mes -> flip elem (join $ snd `map` exportedTypes mes))
265+
266+ -- Update names so unqualified references become qualified, and locally qualified references
267+ -- are replaced with their canoncial qualified names (e.g. M.Map -> Data.Map.Map)
268+ update :: (Ord a, Show a) => String
269+ -> (ImportEnvironment -> M.Map (Qualified a) (Qualified a))
270+ -> (Exports -> a -> Bool)
271+ -> Qualified a
272+ -> Maybe SourcePos
273+ -> Either ErrorStack (Qualified a)
274+ update t getI checkE qname@(Qualified mn' name) pos = positioned $ case (M.lookup qname imports', mn') of
275+ (Just qname', _) -> return qname'
276+ (Nothing, Just mn'') -> do
277+ when (isExplicitQualModule mn'') $ throwError $ mkErrorStack ("Unknown " ++ t ++ " '" ++ show qname ++ "'") Nothing
278+ modExports <- getExports mn''
279+ if checkE modExports name
280+ then return qname
281+ else throwError $ mkErrorStack ("Unknown " ++ t ++ " '" ++ show qname ++ "'") Nothing
282+ _ -> throwError $ mkErrorStack ("Unknown " ++ t ++ " '" ++ show name ++ "'") Nothing
283+ where
284+ isExplicitQualModule :: ModuleName -> Bool
285+ isExplicitQualModule = flip elem $ mapMaybe (\(Qualified q _) -> q) (M.keys imports')
286+ imports' = getI imports
287+ positioned err = case pos of
288+ Nothing -> err
289+ Just pos' -> rethrowWithPosition pos' err
290+
291+ -- Gets the exports for a module, or an error message if the module doesn't exist
292+ getExports :: ModuleName -> Either ErrorStack Exports
293+ getExports mn' = maybe (throwError $ mkErrorStack ("Unknown module '" ++ show mn' ++ "'") Nothing) return $ M.lookup mn' exports
294+
295+-- |
296+-- Finds all exported declarations in a set of modules.
297+--
298+findExports :: [Module] -> Either ErrorStack ExportEnvironment
299+findExports = foldM addModule $ M.singleton (ModuleName [ProperName C.prim]) primExports
300+ where
301+
302+ -- The exported types from the Prim module
303+ primExports = Exports (mkTypeEntry `map` M.keys primTypes) [] []
304+ where
305+ mkTypeEntry (Qualified _ name) = (name, [])
306+
307+ -- Add all of the exported declarations from a module to the global export environment
308+ addModule :: ExportEnvironment -> Module -> Either ErrorStack ExportEnvironment
309+ addModule env (Module mn ds _) = do
310+ env' <- addEmptyModule env mn
311+ rethrow (strMsg ("Error in module " ++ show mn) <>) $ foldM (addDecl mn) env' ds
312+
313+ -- Add a declaration from a module to the global export environment
314+ addDecl :: ModuleName -> ExportEnvironment -> Declaration -> Either ErrorStack ExportEnvironment
315+ addDecl mn env (TypeClassDeclaration tcn _ _ ds) = do
316+ env' <- addTypeClass env mn tcn
317+ foldM go env' ds
318+ where
319+ go env'' (TypeDeclaration name _) = addValue env'' mn name
320+ go env'' (PositionedDeclaration pos d) = rethrowWithPosition pos $ go env'' d
321+ go _ _ = error "Invalid declaration in TypeClassDeclaration"
322+ addDecl mn env (DataDeclaration _ tn _ dcs) = addType env mn tn (map fst dcs)
323+ addDecl mn env (TypeSynonymDeclaration tn _ _) = addType env mn tn []
324+ addDecl mn env (ExternDataDeclaration tn _) = addType env mn tn []
325+ addDecl mn env (ValueDeclaration name _ _ _) = addValue env mn name
326+ addDecl mn env (ExternDeclaration _ name _ _) = addValue env mn name
327+ addDecl mn env (PositionedDeclaration _ d) = addDecl mn env d
328+ addDecl _ env _ = return env
329+
330+-- |
331+-- Filters the exports for a module to ensure only explicit exports are kept in the global exports
332+-- environment.
333+--
334+filterExports :: ModuleName -> [DeclarationRef] -> ExportEnvironment -> Either ErrorStack ExportEnvironment
335+filterExports mn exps env = do
336+ let moduleExports = fromMaybe (error "Module is missing") (mn `M.lookup` env)
337+ moduleExports' <- rethrow (strMsg ("Error in module " ++ show mn) <>) $ filterModule moduleExports
338+ return $ M.insert mn moduleExports' env
339+ where
340+
341+ -- Filter the exports for the specific module
342+ filterModule :: Exports -> Either ErrorStack Exports
343+ filterModule exported = do
344+ types' <- foldM (filterTypes $ exportedTypes exported) [] exps
345+ values <- foldM (filterValues $ exportedValues exported) [] exps
346+ classes <- foldM (filterClasses $ exportedTypeClasses exported) [] exps
347+ return exported { exportedTypes = types', exportedTypeClasses = classes, exportedValues = values }
348+
349+ -- Ensure the exported types and data constructors exist in the module and add them to the set of
350+ -- exports
351+ filterTypes :: [(ProperName, [ProperName])] -> [(ProperName, [ProperName])] -> DeclarationRef -> Either ErrorStack [(ProperName, [ProperName])]
352+ filterTypes expTys result (PositionedDeclarationRef pos r) = rethrowWithPosition pos $ filterTypes expTys result r
353+ filterTypes expTys result (TypeRef name expDcons) = do
354+ dcons <- maybe (throwError $ mkErrorStack ("Cannot export undefined type '" ++ show name ++ "'") Nothing) return $ name `lookup` expTys
355+ dcons' <- maybe (return dcons) (foldM (filterDcons name dcons) []) expDcons
356+ return $ (name, dcons') : result
357+ filterTypes _ result _ = return result
358+
359+ -- Ensure the exported data constructors exists for a type and add them to the list of exports
360+ filterDcons :: ProperName -> [ProperName] -> [ProperName] -> ProperName -> Either ErrorStack [ProperName]
361+ filterDcons tcon exps' result name =
362+ if name `elem` exps'
363+ then return $ name : result
364+ else throwError $ mkErrorStack ("Cannot export undefined data constructor '" ++ show name ++ "' for type '" ++ show tcon ++ "'") Nothing
365+
366+ -- Ensure the exported classes exist in the module and add them to the set of exports
367+ filterClasses :: [ProperName] -> [ProperName] -> DeclarationRef -> Either ErrorStack [ProperName]
368+ filterClasses exps' result (PositionedDeclarationRef pos r) = rethrowWithPosition pos $ filterClasses exps' result r
369+ filterClasses exps' result (TypeClassRef name) =
370+ if name `elem` exps'
371+ then return $ name : result
372+ else throwError $ mkErrorStack ("Cannot export undefined type class '" ++ show name ++ "'") Nothing
373+ filterClasses _ result _ = return result
374+
375+ -- Ensure the exported values exist in the module and add them to the set of exports
376+ filterValues :: [Ident] -> [Ident] -> DeclarationRef -> Either ErrorStack [Ident]
377+ filterValues exps' result (PositionedDeclarationRef pos r) = rethrowWithPosition pos $ filterValues exps' result r
378+ filterValues exps' result (ValueRef name) =
379+ if name `elem` exps'
380+ then return $ name : result
381+ else throwError $ mkErrorStack ("Cannot export undefined value '" ++ show name ++ "'") Nothing
382+ filterValues _ result _ = return result
383+
384+-- |
385+-- Finds the imports within a module, mapping the imported module name to an optional set of
386+-- explicitly imported declarations.
387+--
388+findImports :: [Declaration] -> M.Map ModuleName (Maybe SourcePos, ImportDeclarationType, Maybe ModuleName)
389+findImports = foldl (findImports' Nothing) M.empty
390+ where
391+ findImports' pos result (ImportDeclaration mn typ qual) = M.insert mn (pos, typ, qual) result
392+ findImports' _ result (PositionedDeclaration pos d) = findImports' (Just pos) result d
393+ findImports' _ result _ = result
394+
395+-- |
396+-- Constructs a local environment for a module.
397+--
398+resolveImports :: ExportEnvironment -> Module -> Either ErrorStack ImportEnvironment
399+resolveImports env (Module currentModule decls _) =
400+ foldM resolveImport' (ImportEnvironment M.empty M.empty M.empty M.empty) (M.toList scope)
401+ where
402+
403+ -- A Map from module name to the source position for the import, the list of imports from that
404+ -- module (where Nothing indicates everything is to be imported), and optionally a qualified name
405+ -- for the module
406+ scope :: M.Map ModuleName (Maybe SourcePos, ImportDeclarationType, Maybe ModuleName)
407+ scope = M.insert currentModule (Nothing, Unqualified, Nothing) (findImports decls)
408+
409+ resolveImport' :: ImportEnvironment -> (ModuleName, (Maybe SourcePos, ImportDeclarationType, Maybe ModuleName)) -> Either ErrorStack ImportEnvironment
410+ resolveImport' imp (mn, (pos, typ, impQual)) = do
411+ modExports <- positioned $ maybe (throwError $ mkErrorStack ("Cannot import unknown module '" ++ show mn ++ "'") Nothing) return $ mn `M.lookup` env
412+ positioned $ resolveImport currentModule mn modExports imp impQual typ
413+ where
414+ positioned err = case pos of
415+ Nothing -> err
416+ Just pos' -> rethrowWithPosition pos' err
417+
418+-- |
419+-- Extends the local environment for a module by resolving an import of another module.
420+--
421+resolveImport :: ModuleName -> ModuleName -> Exports -> ImportEnvironment -> Maybe ModuleName -> ImportDeclarationType -> Either ErrorStack ImportEnvironment
422+resolveImport currentModule importModule exps imps impQual =
423+ resolveByType
424+ where
425+
426+ resolveByType :: ImportDeclarationType -> Either ErrorStack ImportEnvironment
427+ resolveByType Unqualified = importAll importExplicit
428+ resolveByType (Qualifying explImports) = (checkedRefs >=> foldM importExplicit imps) explImports
429+ resolveByType (Hiding hiddenImports) = do
430+ hiddenImports' <- checkedRefs hiddenImports
431+ importAll (importNonHidden hiddenImports')
432+
433+ importNonHidden :: [DeclarationRef] -> ImportEnvironment -> DeclarationRef -> Either ErrorStack ImportEnvironment
434+ importNonHidden hidden m ref =
435+ if isHidden hidden ref
436+ then return m
437+ else importExplicit m ref
438+
439+ isHidden :: [DeclarationRef] -> DeclarationRef -> Bool
440+ isHidden hidden ref@(TypeRef _ _) =
441+ let
442+ checkTypeRef _ True _ = True
443+ checkTypeRef (TypeRef _ Nothing) acc (TypeRef _ (Just _)) = acc
444+ checkTypeRef (TypeRef name (Just dctor)) _ (TypeRef name' (Just dctor')) = name == name' && dctor == dctor'
445+ checkTypeRef (TypeRef name _) _ (TypeRef name' Nothing) = name == name'
446+ checkTypeRef (PositionedDeclarationRef _ r) acc hiddenRef = checkTypeRef r acc hiddenRef
447+ checkTypeRef _ acc _ = acc
448+ in foldl (checkTypeRef ref) False hidden
449+ isHidden hidden ref = ref `elem` hidden
450+
451+ -- Import all symbols
452+ importAll :: (ImportEnvironment -> DeclarationRef -> Either ErrorStack ImportEnvironment) -> Either ErrorStack ImportEnvironment
453+ importAll importer = do
454+ imp' <- foldM (\m (name, dctors) -> importer m (TypeRef name (Just dctors))) imps (exportedTypes exps)
455+ imp'' <- foldM (\m name -> importer m (ValueRef name)) imp' (exportedValues exps)
456+ foldM (\m name -> importer m (TypeClassRef name)) imp'' (exportedTypeClasses exps)
457+
458+ -- Import something explicitly
459+ importExplicit :: ImportEnvironment -> DeclarationRef -> Either ErrorStack ImportEnvironment
460+ importExplicit imp (PositionedDeclarationRef pos r) = rethrowWithPosition pos $ importExplicit imp r
461+ importExplicit imp (ValueRef name) = do
462+ values' <- updateImports (importedValues imp) name
463+ return $ imp { importedValues = values' }
464+ importExplicit imp (TypeRef name dctors) = do
465+ types' <- updateImports (importedTypes imp) name
466+ let allDctors = allExportedDataConstructors name
467+ dctors' <- maybe (return allDctors) (mapM $ checkDctorExists allDctors) dctors
468+ dctors'' <- foldM updateImports (importedDataConstructors imp) dctors'
469+ return $ imp { importedTypes = types', importedDataConstructors = dctors'' }
470+ importExplicit imp (TypeClassRef name) = do
471+ typeClasses' <- updateImports (importedTypeClasses imp) name
472+ return $ imp { importedTypeClasses = typeClasses' }
473+ importExplicit _ _ = error "Invalid argument to importExplicit"
474+
475+ -- Check if DeclarationRef points to an existent symbol
476+ checkedRefs :: [DeclarationRef] -> Either ErrorStack [DeclarationRef]
477+ checkedRefs = mapM check
478+ where
479+ check (PositionedDeclarationRef pos r) =
480+ rethrowWithPosition pos $ check r
481+ check ref@(ValueRef name) =
482+ checkImportExists "value" values name >> return ref
483+ check ref@(TypeRef name dctors) = do
484+ _ <- checkImportExists "type" availableTypes name
485+ let allDctors = allExportedDataConstructors name
486+ _ <- maybe (return allDctors) (mapM $ checkDctorExists allDctors) dctors
487+ return ref
488+ check ref@(TypeClassRef name) =
489+ checkImportExists "type class" classes name >> return ref
490+ check _ = error "Invalid argument to checkRefIsValid"
491+
492+ -- Find all exported data constructors for a given type
493+ allExportedDataConstructors :: ProperName -> [ProperName]
494+ allExportedDataConstructors name = fromMaybe [] $ name `lookup` exportedTypes exps
495+
496+ -- Add something to the ImportEnvironment if it does not already exist there
497+ updateImports :: (Ord a, Show a) => M.Map (Qualified a) (Qualified a) -> a -> Either ErrorStack (M.Map (Qualified a) (Qualified a))
498+ updateImports m name = case M.lookup (Qualified impQual name) m of
499+ Nothing -> return $ M.insert (Qualified impQual name) (Qualified (Just importModule) name) m
500+ Just (Qualified Nothing _) -> error "Invalid state in updateImports"
501+ Just x@(Qualified (Just mn) _) -> throwError $ mkErrorStack err Nothing
502+ where
503+ err = if mn == currentModule || importModule == currentModule
504+ then "Definition '" ++ show name ++ "' conflicts with import '" ++ show (Qualified (Just mn) name) ++ "'"
505+ else "Conflicting imports for '" ++ show name ++ "': '" ++ show x ++ "', '" ++ show (Qualified (Just importModule) name) ++ "'"
506+
507+ -- The available values, types, and classes in the module being imported
508+ values = exportedValues exps
509+ availableTypes = fst `map` exportedTypes exps
510+ classes = exportedTypeClasses exps
511+
512+ -- Ensure that an explicitly imported data constructor exists for the type it is being imported
513+ -- from
514+ checkDctorExists :: [ProperName] -> ProperName -> Either ErrorStack ProperName
515+ checkDctorExists = checkImportExists "data constructor"
516+
517+ -- Check that an explicitly imported item exists in the module it is being imported from
518+ checkImportExists :: (Eq a, Show a) => String -> [a] -> a -> Either ErrorStack a
519+ checkImportExists t exports item =
520+ if item `elem` exports
521+ then return item
522+ else throwError $ mkErrorStack ("Cannot import unknown " ++ t ++ " '" ++ show item ++ "' from '" ++ show importModule ++ "'") Nothing
src/Language/PureScript/Sugar/Operators.hsnew file+152
@@ -0,0 +1,152 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.Sugar.Operators
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- This module implements the desugaring pass which reapplies binary operators based
13+-- on their fixity data and removes explicit parentheses.
14+--
15+-- The value parser ignores fixity data when parsing binary operator applications, so
16+-- it is necessary to reorder them here.
17+--
18+-----------------------------------------------------------------------------
19+
20+{-# LANGUAGE Rank2Types, FlexibleContexts #-}
21+
22+module Language.PureScript.Sugar.Operators (
23+ rebracket,
24+ removeSignedLiterals
25+) where
26+
27+import Language.PureScript.Names
28+import Language.PureScript.AST
29+import Language.PureScript.Errors
30+
31+import Control.Applicative
32+import Control.Monad.State
33+import Control.Monad.Error.Class
34+
35+import Data.Monoid ((<>))
36+import Data.Function (on)
37+import Data.Functor.Identity
38+import Data.List (groupBy, sortBy)
39+
40+import qualified Text.Parsec as P
41+import qualified Text.Parsec.Pos as P
42+import qualified Text.Parsec.Expr as P
43+
44+import qualified Language.PureScript.Constants as C
45+
46+-- |
47+-- Remove explicit parentheses and reorder binary operator applications
48+--
49+rebracket :: [Module] -> Either ErrorStack [Module]
50+rebracket ms = do
51+ let fixities = concatMap collectFixities ms
52+ ensureNoDuplicates $ map (\(i, pos, _) -> (i, pos)) fixities
53+ let opTable = customOperatorTable $ map (\(i, _, f) -> (i, f)) fixities
54+ mapM (rebracketModule opTable) ms
55+
56+removeSignedLiterals :: Module -> Module
57+removeSignedLiterals (Module mn ds exts) = Module mn (map f' ds) exts
58+ where
59+ (f', _, _) = everywhereOnValues id go id
60+
61+ go (UnaryMinus (NumericLiteral (Left n))) = NumericLiteral (Left $ negate n)
62+ go (UnaryMinus (NumericLiteral (Right n))) = NumericLiteral (Right $ negate n)
63+ go (UnaryMinus val) = App (Var (Qualified (Just (ModuleName [ProperName C.prelude])) (Ident C.negate))) val
64+ go other = other
65+
66+rebracketModule :: [[(Qualified Ident, Expr -> Expr -> Expr, Associativity)]] -> Module -> Either ErrorStack Module
67+rebracketModule opTable (Module mn ds exts) =
68+ let (f, _, _) = everywhereOnValuesTopDownM return (matchOperators opTable) return
69+ in Module mn <$> (map removeParens <$> parU ds f) <*> pure exts
70+
71+removeParens :: Declaration -> Declaration
72+removeParens =
73+ let (f, _, _) = everywhereOnValues id go id
74+ in f
75+ where
76+ go (Parens val) = val
77+ go val = val
78+
79+collectFixities :: Module -> [(Qualified Ident, SourcePos, Fixity)]
80+collectFixities (Module moduleName ds _) = concatMap collect ds
81+ where
82+ collect :: Declaration -> [(Qualified Ident, SourcePos, Fixity)]
83+ collect (PositionedDeclaration pos (FixityDeclaration fixity name)) = [(Qualified (Just moduleName) (Op name), pos, fixity)]
84+ collect FixityDeclaration{} = error "Fixity without srcpos info"
85+ collect _ = []
86+
87+ensureNoDuplicates :: [(Qualified Ident, SourcePos)] -> Either ErrorStack ()
88+ensureNoDuplicates m = go $ sortBy (compare `on` fst) m
89+ where
90+ go [] = return ()
91+ go [_] = return ()
92+ go ((x@(Qualified (Just mn) name), _) : (y, pos) : _) | x == y =
93+ rethrow (strMsg ("Error in module " ++ show mn) <>) $
94+ rethrowWithPosition pos $
95+ throwError $ mkErrorStack ("Redefined fixity for " ++ show name) Nothing
96+ go (_ : rest) = go rest
97+
98+customOperatorTable :: [(Qualified Ident, Fixity)] -> [[(Qualified Ident, Expr -> Expr -> Expr, Associativity)]]
99+customOperatorTable fixities =
100+ let
101+ applyUserOp ident t1 = App (App (Var ident) t1)
102+ userOps = map (\(name, Fixity a p) -> (name, applyUserOp name, p, a)) fixities
103+ sorted = sortBy (flip compare `on` (\(_, _, p, _) -> p)) userOps
104+ groups = groupBy ((==) `on` (\(_, _, p, _) -> p)) sorted
105+ in
106+ map (map (\(name, f, _, a) -> (name, f, a))) groups
107+
108+type Chain = [Either Expr (Qualified Ident)]
109+
110+matchOperators :: [[(Qualified Ident, Expr -> Expr -> Expr, Associativity)]] -> Expr -> Either ErrorStack Expr
111+matchOperators ops = parseChains
112+ where
113+ parseChains :: Expr -> Either ErrorStack Expr
114+ parseChains b@BinaryNoParens{} = bracketChain (extendChain b)
115+ parseChains other = return other
116+ extendChain :: Expr -> Chain
117+ extendChain (BinaryNoParens name l r) = Left l : Right name : extendChain r
118+ extendChain other = [Left other]
119+ bracketChain :: Chain -> Either ErrorStack Expr
120+ bracketChain = either (Left . (`mkErrorStack` Nothing) . show) Right . P.parse (P.buildExpressionParser opTable parseValue <* P.eof) "operator expression"
121+ opTable = [P.Infix (P.try (parseTicks >>= \ident -> return (\t1 t2 -> App (App (Var ident) t1) t2))) P.AssocLeft]
122+ : map (map (\(name, f, a) -> P.Infix (P.try (matchOp name) >> return f) (toAssoc a))) ops
123+ ++ [[ P.Infix (P.try (parseOp >>= \ident -> return (\t1 t2 -> App (App (Var ident) t1) t2))) P.AssocLeft ]]
124+
125+toAssoc :: Associativity -> P.Assoc
126+toAssoc Infixl = P.AssocLeft
127+toAssoc Infixr = P.AssocRight
128+toAssoc Infix = P.AssocNone
129+
130+token :: (P.Stream s Identity t, Show t) => (t -> Maybe a) -> P.Parsec s u a
131+token = P.token show (const (P.initialPos ""))
132+
133+parseValue :: P.Parsec Chain () Expr
134+parseValue = token (either Just (const Nothing)) P.<?> "expression"
135+
136+parseOp :: P.Parsec Chain () (Qualified Ident)
137+parseOp = token (either (const Nothing) fromOp) P.<?> "operator"
138+ where
139+ fromOp q@(Qualified _ (Op _)) = Just q
140+ fromOp _ = Nothing
141+
142+parseTicks :: P.Parsec Chain () (Qualified Ident)
143+parseTicks = token (either (const Nothing) fromOp) P.<?> "infix function"
144+ where
145+ fromOp q@(Qualified _ (Ident _)) = Just q
146+ fromOp _ = Nothing
147+
148+matchOp :: Qualified Ident -> P.Parsec Chain () ()
149+matchOp op = do
150+ ident <- parseOp
151+ guard $ ident == op
152+
src/Language/PureScript/Sugar/TypeClasses.hsnew file+287
@@ -0,0 +1,287 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.Sugar.TypeClasses
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- This module implements the desugaring pass which creates type synonyms for type class dictionaries
13+-- and dictionary expressions for type class instances.
14+--
15+-----------------------------------------------------------------------------
16+
17+module Language.PureScript.Sugar.TypeClasses (
18+ desugarTypeClasses
19+) where
20+
21+import Language.PureScript.AST
22+import Language.PureScript.Names
23+import Language.PureScript.Types
24+import Language.PureScript.Kinds
25+import Language.PureScript.Sugar.CaseDeclarations
26+import Language.PureScript.Environment
27+import Language.PureScript.Errors
28+import Language.PureScript.Supply
29+import Language.PureScript.Pretty.Types (prettyPrintTypeAtom)
30+
31+import qualified Language.PureScript.Constants as C
32+
33+import Control.Applicative
34+import Control.Monad.Error
35+import Control.Monad.State
36+import Control.Arrow (first, second)
37+import Data.List ((\\), find)
38+import Data.Monoid ((<>))
39+import Data.Maybe (catMaybes, mapMaybe, isJust)
40+
41+import qualified Data.Map as M
42+
43+type MemberMap = M.Map (ModuleName, ProperName) Declaration
44+
45+type Desugar = StateT MemberMap (SupplyT (Either ErrorStack))
46+
47+-- |
48+-- Add type synonym declarations for type class dictionary types, and value declarations for type class
49+-- instance dictionary expressions.
50+--
51+desugarTypeClasses :: [Module] -> SupplyT (Either ErrorStack) [Module]
52+desugarTypeClasses = flip evalStateT M.empty . mapM desugarModule
53+
54+desugarModule :: Module -> Desugar Module
55+desugarModule (Module name decls (Just exps)) = do
56+ (newExpss, declss) <- unzip <$> parU decls (desugarDecl name exps)
57+ return $ Module name (concat declss) $ Just (exps ++ catMaybes newExpss)
58+desugarModule _ = error "Exports should have been elaborated in name desugaring"
59+
60+{- Desugar type class and type class instance declarations
61+--
62+-- Type classes become type synonyms for their dictionaries, and type instances become dictionary declarations.
63+-- Additional values are generated to access individual members of a dictionary, with the appropriate type.
64+--
65+-- E.g. the following
66+--
67+-- module Test where
68+--
69+-- class Foo a where
70+-- foo :: a -> a
71+--
72+-- instance fooString :: Foo String where
73+-- foo s = s ++ s
74+--
75+-- instance fooArray :: (Foo a) => Foo [a] where
76+-- foo = map foo
77+--
78+-- {- Superclasses -}
79+--
80+-- class (Foo a) <= Sub a where
81+-- sub :: a
82+--
83+-- instance subString :: Sub String where
84+-- sub = ""
85+--
86+-- becomes:
87+--
88+-- <TypeClassDeclaration Foo ...>
89+--
90+-- type Foo a = { foo :: a -> a }
91+--
92+-- -- this following type is marked as not needing to be checked so a new Abs
93+-- -- is not introduced around the definition in type checking, but when
94+-- -- called the dictionary value is still passed in for the `dict` argument
95+-- foo :: forall a. (Foo a) => a -> a
96+-- foo dict = dict.foo
97+--
98+-- fooString :: {} -> Foo String
99+-- fooString _ = <TypeClassDictionaryConstructorApp Foo { foo: \s -> s ++ s }>
100+--
101+-- fooArray :: forall a. (Foo a) => Foo [a]
102+-- fooArray = <TypeClassDictionaryConstructorApp Foo { foo: map foo }>
103+--
104+-- {- Superclasses -}
105+--
106+-- <TypeClassDeclaration Sub ...>
107+--
108+-- type Sub a = { sub :: a
109+-- , "__superclass_Foo_0" :: {} -> Foo a
110+-- }
111+--
112+-- -- As with `foo` above, this type is unchecked at the declaration
113+-- sub :: forall a. (Sub a) => a
114+-- sub dict = dict.sub
115+--
116+-- subString :: {} -> Sub String
117+-- subString _ = { sub: "",
118+-- , "__superclass_Foo_0": \_ -> <SuperClassDictionary Foo String>
119+-- }
120+--
121+-- and finally as the generated javascript:
122+--
123+-- function Foo(foo) {
124+-- this.foo = foo;
125+-- };
126+--
127+-- var foo = function (dict) {
128+-- return dict.foo;
129+-- };
130+--
131+-- var fooString = function (_) {
132+-- return new Foo(function (s) {
133+-- return s + s;
134+-- });
135+-- };
136+--
137+-- var fooArray = function (__dict_Foo_15) {
138+-- return new Foo(map(foo(__dict_Foo_15)));
139+-- };
140+--
141+-- function Sub(__superclass_Foo_0, sub) {
142+-- this["__superclass_Foo_0"] = __superclass_Foo_0;
143+-- this.sub = sub;
144+-- };
145+--
146+-- var sub = function (dict) {
147+-- return dict.sub;
148+-- };
149+--
150+-- var subString = function (_) {
151+-- return new Sub(fooString, "");
152+-- };
153+-}
154+desugarDecl :: ModuleName -> [DeclarationRef] -> Declaration -> Desugar (Maybe DeclarationRef, [Declaration])
155+desugarDecl mn exps = go
156+ where
157+ go d@(TypeClassDeclaration name args implies members) = do
158+ modify (M.insert (mn, name) d)
159+ return $ (Nothing, d : typeClassDictionaryDeclaration name args implies members : map (typeClassMemberToDictionaryAccessor mn name args) members)
160+ go d@(ExternInstanceDeclaration name _ className tys) = return (expRef name className tys, [d])
161+ go d@(TypeInstanceDeclaration name deps className tys members) = do
162+ desugared <- lift $ desugarCases members
163+ dictDecl <- typeInstanceDictionaryDeclaration name mn deps className tys desugared
164+ return $ (expRef name className tys, [d, dictDecl])
165+ go (PositionedDeclaration pos d) = do
166+ (dr, ds) <- rethrowWithPosition pos $ desugarDecl mn exps d
167+ return (dr, map (PositionedDeclaration pos) ds)
168+ go other = return (Nothing, [other])
169+
170+ expRef :: Ident -> Qualified ProperName -> [Type] -> Maybe DeclarationRef
171+ expRef name className tys
172+ | isExportedClass className && all isExportedType (getConstructors `concatMap` tys) = Just $ TypeInstanceRef name
173+ | otherwise = Nothing
174+
175+ isExportedClass :: Qualified ProperName -> Bool
176+ isExportedClass = isExported (elem . TypeClassRef)
177+
178+ isExportedType :: Qualified ProperName -> Bool
179+ isExportedType = isExported $ \pn -> isJust . find (matchesTypeRef pn)
180+
181+ isExported :: (ProperName -> [DeclarationRef] -> Bool) -> Qualified ProperName -> Bool
182+ isExported test (Qualified (Just mn') pn) = mn /= mn' || test pn exps
183+ isExported _ _ = error "Names should have been qualified in name desugaring"
184+
185+ matchesTypeRef :: ProperName -> DeclarationRef -> Bool
186+ matchesTypeRef pn (TypeRef pn' _) = pn == pn'
187+ matchesTypeRef _ _ = False
188+
189+ getConstructors :: Type -> [Qualified ProperName]
190+ getConstructors = everythingOnTypes (++) getConstructor
191+
192+ getConstructor :: Type -> [Qualified ProperName]
193+ getConstructor (TypeConstructor tcname) = [tcname]
194+ getConstructor _ = []
195+
196+memberToNameAndType :: Declaration -> (Ident, Type)
197+memberToNameAndType (TypeDeclaration ident ty) = (ident, ty)
198+memberToNameAndType (PositionedDeclaration _ d) = memberToNameAndType d
199+memberToNameAndType _ = error "Invalid declaration in type class definition"
200+
201+typeClassDictionaryDeclaration :: ProperName -> [(String, Maybe Kind)] -> [(Qualified ProperName, [Type])] -> [Declaration] -> Declaration
202+typeClassDictionaryDeclaration name args implies members =
203+ let superclassTypes = [ (fieldName, function unit tySynApp)
204+ | (index, (superclass, tyArgs)) <- zip [0..] implies
205+ , let tySynApp = foldl TypeApp (TypeConstructor superclass) tyArgs
206+ , let fieldName = mkSuperclassDictionaryName superclass index
207+ ]
208+ members' = map (first runIdent . memberToNameAndType) members
209+ mtys = members' ++ superclassTypes
210+ in TypeSynonymDeclaration name args (TypeApp tyObject $ rowFromList (mtys, REmpty))
211+
212+typeClassMemberToDictionaryAccessor :: ModuleName -> ProperName -> [(String, Maybe Kind)] -> Declaration -> Declaration
213+typeClassMemberToDictionaryAccessor mn name args (TypeDeclaration ident ty) =
214+ ValueDeclaration ident TypeClassAccessorImport [] $ Right $
215+ TypedValue False (Abs (Left $ Ident "dict") (Accessor (runIdent ident) (Var $ Qualified Nothing (Ident "dict")))) $
216+ moveQuantifiersToFront (quantify (ConstrainedType [(Qualified (Just mn) name, map (TypeVar . fst) args)] ty))
217+typeClassMemberToDictionaryAccessor mn name args (PositionedDeclaration pos d) =
218+ PositionedDeclaration pos $ typeClassMemberToDictionaryAccessor mn name args d
219+typeClassMemberToDictionaryAccessor _ _ _ _ = error "Invalid declaration in type class definition"
220+
221+mkSuperclassDictionaryName :: Qualified ProperName -> Integer -> String
222+mkSuperclassDictionaryName pn index = C.__superclass_ ++ show pn ++ "_" ++ show index
223+
224+unit :: Type
225+unit = TypeApp tyObject REmpty
226+
227+typeInstanceDictionaryDeclaration :: Ident -> ModuleName -> [(Qualified ProperName, [Type])] -> Qualified ProperName -> [Type] -> [Declaration] -> Desugar Declaration
228+typeInstanceDictionaryDeclaration name mn deps className tys decls =
229+ rethrow (strMsg ("Error in type class instance " ++ show className ++ " " ++ unwords (map prettyPrintTypeAtom tys) ++ ":") <>) $ do
230+ m <- get
231+
232+ -- Lookup the type arguments and member types for the type class
233+ (TypeClassDeclaration _ args implies tyDecls) <- lift . lift $
234+ maybe (Left $ mkErrorStack ("Type class " ++ show className ++ " is undefined") Nothing) Right $
235+ M.lookup (qualify mn className) m
236+
237+ case mapMaybe declName tyDecls \\ mapMaybe declName decls of
238+ x : _ -> throwError $ mkErrorStack ("Member '" ++ show x ++ "' has not been implemented") Nothing
239+ [] -> do
240+
241+ let instanceTys = map memberToNameAndType tyDecls
242+
243+ -- Replace the type arguments with the appropriate types in the member types
244+ let memberTypes = map (second (replaceAllTypeVars (zip (map fst args) tys))) instanceTys
245+ -- Create values for the type instance members
246+ memberNames <- map (first runIdent) <$> mapM (memberToNameAndValue memberTypes) decls
247+ -- Create the type of the dictionary
248+ -- The type is an object type, but depending on type instance dependencies, may be constrained.
249+ -- The dictionary itself is an object literal.
250+ let superclasses =
251+ [ (fieldName, Abs (Left (Ident C.__unused)) (SuperClassDictionary superclass tyArgs))
252+ | (index, (superclass, suTyArgs)) <- zip [0..] implies
253+ , let tyArgs = map (replaceAllTypeVars (zip (map fst args) tys)) suTyArgs
254+ , let fieldName = mkSuperclassDictionaryName superclass index
255+ ]
256+
257+ let memberNames' = ObjectLiteral (memberNames ++ superclasses)
258+ dictTy = foldl TypeApp (TypeConstructor className) tys
259+ constrainedTy = quantify (if null deps then dictTy else ConstrainedType deps dictTy)
260+ dict = TypeClassDictionaryConstructorApp className memberNames'
261+ result = ValueDeclaration name TypeInstanceDictionaryValue [] (Right (TypedValue True dict constrainedTy))
262+ return result
263+
264+ where
265+
266+ declName :: Declaration -> Maybe Ident
267+ declName (PositionedDeclaration _ d) = declName d
268+ declName (ValueDeclaration ident _ _ _) = Just ident
269+ declName (TypeDeclaration ident _) = Just ident
270+ declName _ = Nothing
271+
272+ memberToNameAndValue :: [(Ident, Type)] -> Declaration -> Desugar (Ident, Expr)
273+ memberToNameAndValue tys' d@(ValueDeclaration ident _ _ _) = do
274+ _ <- lift . lift . maybe (Left $ mkErrorStack ("Type class does not define member '" ++ show ident ++ "'") Nothing) Right $ lookup ident tys'
275+ let memberValue = typeInstanceDictionaryEntryValue d
276+ return (ident, memberValue)
277+ memberToNameAndValue tys' (PositionedDeclaration pos d) = rethrowWithPosition pos $ do
278+ (ident, val) <- memberToNameAndValue tys' d
279+ return (ident, PositionedValue pos val)
280+ memberToNameAndValue _ _ = error "Invalid declaration in type instance definition"
281+
282+ typeInstanceDictionaryEntryValue :: Declaration -> Expr
283+ typeInstanceDictionaryEntryValue (ValueDeclaration _ _ [] (Right val)) = val
284+ typeInstanceDictionaryEntryValue (PositionedDeclaration pos d) = PositionedValue pos (typeInstanceDictionaryEntryValue d)
285+ typeInstanceDictionaryEntryValue _ = error "Invalid declaration in type instance definition"
286+
287+
src/Language/PureScript/Sugar/TypeDeclarations.hsnew file+69
@@ -0,0 +1,69 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.Sugar.TypeDeclarations
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- This module implements the desugaring pass which replaces top-level type declarations with
13+-- type annotations on the corresponding expression.
14+--
15+-----------------------------------------------------------------------------
16+
17+module Language.PureScript.Sugar.TypeDeclarations (
18+ desugarTypeDeclarations,
19+ desugarTypeDeclarationsModule
20+) where
21+
22+import Data.Monoid ((<>))
23+
24+import Control.Applicative
25+import Control.Monad.Error.Class
26+import Control.Monad (forM)
27+
28+import Language.PureScript.AST
29+import Language.PureScript.Names
30+import Language.PureScript.Environment
31+import Language.PureScript.Errors
32+import Language.PureScript.Traversals
33+
34+-- |
35+-- Replace all top level type declarations in a module with type annotations
36+--
37+desugarTypeDeclarationsModule :: [Module] -> Either ErrorStack [Module]
38+desugarTypeDeclarationsModule ms = forM ms $ \(Module name ds exps) ->
39+ rethrow (strMsg ("Error in module " ++ show name) <>) $
40+ Module name <$> desugarTypeDeclarations ds <*> pure exps
41+
42+-- |
43+-- Replace all top level type declarations with type annotations
44+--
45+desugarTypeDeclarations :: [Declaration] -> Either ErrorStack [Declaration]
46+desugarTypeDeclarations (PositionedDeclaration pos d : ds) = do
47+ (d' : ds') <- rethrowWithPosition pos $ desugarTypeDeclarations (d : ds)
48+ return (PositionedDeclaration pos d' : ds')
49+desugarTypeDeclarations (TypeDeclaration name ty : d : rest) = do
50+ (_, nameKind, val) <- fromValueDeclaration d
51+ desugarTypeDeclarations (ValueDeclaration name nameKind [] (Right (TypedValue True val ty)) : rest)
52+ where
53+ fromValueDeclaration :: Declaration -> Either ErrorStack (Ident, NameKind, Expr)
54+ fromValueDeclaration (ValueDeclaration name' nameKind [] (Right val)) | name == name' = return (name', nameKind, val)
55+ fromValueDeclaration (PositionedDeclaration pos d') = do
56+ (ident, nameKind, val) <- rethrowWithPosition pos $ fromValueDeclaration d'
57+ return (ident, nameKind, PositionedValue pos val)
58+ fromValueDeclaration _ = throwError $ mkErrorStack ("Orphan type declaration for " ++ show name) Nothing
59+desugarTypeDeclarations (TypeDeclaration name _ : []) = throwError $ mkErrorStack ("Orphan type declaration for " ++ show name) Nothing
60+desugarTypeDeclarations (ValueDeclaration name nameKind bs val : rest) = do
61+ let (_, f, _) = everywhereOnValuesTopDownM return go return
62+ f' (Left gs) = Left <$> mapM (pairM return f) gs
63+ f' (Right v) = Right <$> f v
64+ (:) <$> (ValueDeclaration name nameKind bs <$> f' val) <*> desugarTypeDeclarations rest
65+ where
66+ go (Let ds val') = Let <$> desugarTypeDeclarations ds <*> pure val'
67+ go other = return other
68+desugarTypeDeclarations (d:ds) = (:) d <$> desugarTypeDeclarations ds
69+desugarTypeDeclarations [] = return []
src/Language/PureScript/Supply.hsnew file+56
@@ -0,0 +1,56 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.Supply
4+-- Copyright : (c) Phil Freeman 2014
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- Fresh variable supply
13+--
14+-----------------------------------------------------------------------------
15+
16+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
17+{-# LANGUAGE FlexibleInstances #-}
18+{-# LANGUAGE MultiParamTypeClasses #-}
19+{-# LANGUAGE UndecidableInstances #-}
20+
21+module Language.PureScript.Supply where
22+
23+import Data.Functor.Identity
24+
25+import Control.Applicative
26+import Control.Monad.State
27+import Control.Monad.Error.Class
28+
29+newtype SupplyT m a = SupplyT { unSupplyT :: StateT Integer m a } deriving (Functor, Applicative, Monad, MonadTrans)
30+
31+runSupplyT :: Integer -> SupplyT m a -> m (a, Integer)
32+runSupplyT n = flip runStateT n . unSupplyT
33+
34+evalSupplyT :: (Functor m) => Integer -> SupplyT m a -> m a
35+evalSupplyT n = fmap fst . runSupplyT n
36+
37+type Supply = SupplyT Identity
38+
39+runSupply :: Integer -> Supply a -> (a, Integer)
40+runSupply n = runIdentity . runSupplyT n
41+
42+evalSupply :: Integer -> Supply a -> a
43+evalSupply n = runIdentity . evalSupplyT n
44+
45+fresh :: (Monad m) => SupplyT m Integer
46+fresh = SupplyT $ do
47+ n <- get
48+ put (n + 1)
49+ return n
50+
51+freshName :: (Functor m, Monad m) => SupplyT m String
52+freshName = ('_' :) . show <$> fresh
53+
54+instance (MonadError e m) => MonadError e (SupplyT m) where
55+ throwError = SupplyT . throwError
56+ catchError e f = SupplyT $ catchError (unSupplyT e) (unSupplyT . f)
src/Language/PureScript/Traversals.hsnew file+41
@@ -0,0 +1,41 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.Traversals
4+-- Copyright : (c) 2014 Phil Freeman
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- | Common functions for implementing generic traversals
12+--
13+-----------------------------------------------------------------------------
14+
15+module Language.PureScript.Traversals where
16+
17+import Control.Applicative
18+
19+fstM :: (Functor f) => (a -> f c) -> (a, b) -> f (c, b)
20+fstM f (a, b) = flip (,) b <$> f a
21+
22+sndM :: (Functor f) => (b -> f c) -> (a, b) -> f (a, c)
23+sndM f (a, b) = (,) a <$> f b
24+
25+thirdM :: (Functor f) => (c -> f d) -> (a, b, c) -> f (a, b, d)
26+thirdM f (a, b, c) = (,,) a b <$> f c
27+
28+pairM :: (Applicative f) => (a -> f c) -> (b -> f d) -> (a, b) -> f (c, d)
29+pairM f g (a, b) = (,) <$> f a <*> g b
30+
31+maybeM :: (Applicative f) => (a -> f b) -> Maybe a -> f (Maybe b)
32+maybeM _ Nothing = pure Nothing
33+maybeM f (Just a) = Just <$> f a
34+
35+eitherM :: (Applicative f) => (a -> f c) -> (b -> f d) -> Either a b -> f (Either c d)
36+eitherM f _ (Left a) = Left <$> f a
37+eitherM _ g (Right b) = Right <$> g b
38+
39+defS :: (Monad m) => st -> val -> m (st, val)
40+defS s val = return (s, val)
41+
src/Language/PureScript/TypeChecker.hsnew file+343
@@ -0,0 +1,343 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.TypeChecker
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- The top-level type checker, which checks all declarations in a module.
13+--
14+-----------------------------------------------------------------------------
15+
16+{-# LANGUAGE FlexibleInstances #-}
17+
18+module Language.PureScript.TypeChecker (
19+ module T,
20+ typeCheckModule
21+) where
22+
23+import Language.PureScript.TypeChecker.Monad as T
24+import Language.PureScript.TypeChecker.Kinds as T
25+import Language.PureScript.TypeChecker.Types as T
26+import Language.PureScript.TypeChecker.Synonyms as T
27+
28+import Data.Maybe
29+import Data.List (nub, (\\), find, intercalate)
30+import Data.Monoid ((<>))
31+import Data.Foldable (for_)
32+import qualified Data.Map as M
33+
34+import Control.Monad.State
35+import Control.Monad.Error
36+
37+import Language.PureScript.Types
38+import Language.PureScript.Names
39+import Language.PureScript.Kinds
40+import Language.PureScript.AST
41+import Language.PureScript.TypeClassDictionaries
42+import Language.PureScript.Environment
43+import Language.PureScript.Errors
44+
45+addDataType :: ModuleName -> DataDeclType -> ProperName -> [(String, Maybe Kind)] -> [(ProperName, [Type])] -> Kind -> Check ()
46+addDataType moduleName dtype name args dctors ctorKind = do
47+ env <- getEnv
48+ putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (ctorKind, DataType args dctors) (types env) }
49+ forM_ dctors $ \(dctor, tys) ->
50+ rethrow (strMsg ("Error in data constructor " ++ show dctor) <>) $
51+ addDataConstructor moduleName dtype name (map fst args) dctor tys
52+
53+addDataConstructor :: ModuleName -> DataDeclType -> ProperName -> [String] -> ProperName -> [Type] -> Check ()
54+addDataConstructor moduleName dtype name args dctor tys = do
55+ env <- getEnv
56+ let retTy = foldl TypeApp (TypeConstructor (Qualified (Just moduleName) name)) (map TypeVar args)
57+ let dctorTy = foldr function retTy tys
58+ let polyType = mkForAll args dctorTy
59+ putEnv $ env { dataConstructors = M.insert (Qualified (Just moduleName) dctor) (dtype, name, polyType) (dataConstructors env) }
60+
61+addTypeSynonym :: ModuleName -> ProperName -> [(String, Maybe Kind)] -> Type -> Kind -> Check ()
62+addTypeSynonym moduleName name args ty kind = do
63+ env <- getEnv
64+ putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (kind, TypeSynonym) (types env)
65+ , typeSynonyms = M.insert (Qualified (Just moduleName) name) (args, ty) (typeSynonyms env) }
66+
67+valueIsNotDefined :: ModuleName -> Ident -> Check ()
68+valueIsNotDefined moduleName name = do
69+ env <- getEnv
70+ case M.lookup (moduleName, name) (names env) of
71+ Just _ -> throwError . strMsg $ show name ++ " is already defined"
72+ Nothing -> return ()
73+
74+addValue :: ModuleName -> Ident -> Type -> NameKind -> Check ()
75+addValue moduleName name ty nameKind = do
76+ env <- getEnv
77+ putEnv (env { names = M.insert (moduleName, name) (ty, nameKind, Defined) (names env) })
78+
79+addTypeClass :: ModuleName -> ProperName -> [(String, Maybe Kind)] -> [(Qualified ProperName, [Type])] -> [Declaration] -> Check ()
80+addTypeClass moduleName pn args implies ds =
81+ let members = map toPair ds in
82+ modify $ \st -> st { checkEnv = (checkEnv st) { typeClasses = M.insert (Qualified (Just moduleName) pn) (args, members, implies) (typeClasses . checkEnv $ st) } }
83+ where
84+ toPair (TypeDeclaration ident ty) = (ident, ty)
85+ toPair (PositionedDeclaration _ d) = toPair d
86+ toPair _ = error "Invalid declaration in TypeClassDeclaration"
87+
88+addTypeClassDictionaries :: [TypeClassDictionaryInScope] -> Check ()
89+addTypeClassDictionaries entries =
90+ let mentries = M.fromList [ ((canonicalizeDictionary entry, mn), entry) | entry@TypeClassDictionaryInScope{ tcdName = Qualified mn _ } <- entries ]
91+ in modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = (typeClassDictionaries . checkEnv $ st) `M.union` mentries } }
92+
93+checkDuplicateTypeArguments :: [String] -> Check ()
94+checkDuplicateTypeArguments args = for_ firstDup $ \dup ->
95+ throwError . strMsg $ "Duplicate type argument '" ++ dup ++ "'"
96+ where
97+ firstDup :: Maybe String
98+ firstDup = listToMaybe $ args \\ nub args
99+
100+checkTypeClassInstance :: ModuleName -> Type -> Check ()
101+checkTypeClassInstance _ (TypeVar _) = return ()
102+checkTypeClassInstance _ (TypeConstructor ctor) = do
103+ env <- getEnv
104+ when (ctor `M.member` typeSynonyms env) . throwError . strMsg $ "Type synonym instances are disallowed"
105+ return ()
106+checkTypeClassInstance m (TypeApp t1 t2) = checkTypeClassInstance m t1 >> checkTypeClassInstance m t2
107+checkTypeClassInstance _ ty = throwError $ mkErrorStack "Type class instance head is invalid." (Just (TypeError ty))
108+
109+-- |
110+-- Type check all declarations in a module
111+--
112+-- At this point, many declarations will have been desugared, but it is still necessary to
113+--
114+-- * Kind-check all types and add them to the @Environment@
115+--
116+-- * Type-check all values and add them to the @Environment@
117+--
118+-- * Bring type class instances into scope
119+--
120+-- * Process module imports
121+--
122+typeCheckAll :: Maybe ModuleName -> ModuleName -> [DeclarationRef] -> [Declaration] -> Check [Declaration]
123+typeCheckAll mainModuleName moduleName exps = go
124+ where
125+ go :: [Declaration] -> Check [Declaration]
126+ go [] = return []
127+ go (DataDeclaration dtype name args dctors : rest) = do
128+ rethrow (strMsg ("Error in type constructor " ++ show name) <>) $ do
129+ when (dtype == Newtype) $ checkNewtype dctors
130+ checkDuplicateTypeArguments $ map fst args
131+ ctorKind <- kindsOf True moduleName name args (concatMap snd dctors)
132+ let args' = args `withKinds` ctorKind
133+ addDataType moduleName dtype name args' dctors ctorKind
134+ ds <- go rest
135+ return $ DataDeclaration dtype name args dctors : ds
136+ where
137+ checkNewtype :: [(ProperName, [Type])] -> Check ()
138+ checkNewtype [(_, [_])] = return ()
139+ checkNewtype [(_, _)] = throwError . strMsg $ "newtypes constructors must have a single argument"
140+ checkNewtype _ = throwError . strMsg $ "newtypes must have a single constructor"
141+ go (d@(DataBindingGroupDeclaration tys) : rest) = do
142+ rethrow (strMsg "Error in data binding group" <>) $ do
143+ let syns = mapMaybe toTypeSynonym tys
144+ let dataDecls = mapMaybe toDataDecl tys
145+ (syn_ks, data_ks) <- kindsOfAll moduleName syns (map (\(_, name, args, dctors) -> (name, args, concatMap snd dctors)) dataDecls)
146+ forM_ (zip dataDecls data_ks) $ \((dtype, name, args, dctors), ctorKind) -> do
147+ checkDuplicateTypeArguments $ map fst args
148+ let args' = args `withKinds` ctorKind
149+ addDataType moduleName dtype name args' dctors ctorKind
150+ forM_ (zip syns syn_ks) $ \((name, args, ty), kind) -> do
151+ checkDuplicateTypeArguments $ map fst args
152+ let args' = args `withKinds` kind
153+ addTypeSynonym moduleName name args' ty kind
154+ ds <- go rest
155+ return $ d : ds
156+ where
157+ toTypeSynonym (TypeSynonymDeclaration nm args ty) = Just (nm, args, ty)
158+ toTypeSynonym (PositionedDeclaration _ d') = toTypeSynonym d'
159+ toTypeSynonym _ = Nothing
160+ toDataDecl (DataDeclaration dtype nm args dctors) = Just (dtype, nm, args, dctors)
161+ toDataDecl (PositionedDeclaration _ d') = toDataDecl d'
162+ toDataDecl _ = Nothing
163+ go (TypeSynonymDeclaration name args ty : rest) = do
164+ rethrow (strMsg ("Error in type synonym " ++ show name) <>) $ do
165+ checkDuplicateTypeArguments $ map fst args
166+ kind <- kindsOf False moduleName name args [ty]
167+ let args' = args `withKinds` kind
168+ addTypeSynonym moduleName name args' ty kind
169+ ds <- go rest
170+ return $ TypeSynonymDeclaration name args ty : ds
171+ go (TypeDeclaration _ _ : _) = error "Type declarations should have been removed"
172+ go (ValueDeclaration name nameKind [] (Right val) : rest) = do
173+ d <- rethrow (strMsg ("Error in declaration " ++ show name) <>) $ do
174+ valueIsNotDefined moduleName name
175+ [(_, (val', ty))] <- typesOf mainModuleName moduleName [(name, val)]
176+ addValue moduleName name ty nameKind
177+ return $ ValueDeclaration name nameKind [] $ Right val'
178+ ds <- go rest
179+ return $ d : ds
180+ go (ValueDeclaration{} : _) = error "Binders were not desugared"
181+ go (BindingGroupDeclaration vals : rest) = do
182+ d <- rethrow (strMsg ("Error in binding group " ++ show (map (\(ident, _, _) -> ident) vals)) <>) $ do
183+ forM_ (map (\(ident, _, _) -> ident) vals) $ \name ->
184+ valueIsNotDefined moduleName name
185+ tys <- typesOf mainModuleName moduleName $ map (\(ident, _, ty) -> (ident, ty)) vals
186+ vals' <- forM [ (name, val, nameKind, ty)
187+ | (name, nameKind, _) <- vals
188+ , (name', (val, ty)) <- tys
189+ , name == name'
190+ ] $ \(name, val, nameKind, ty) -> do
191+ addValue moduleName name ty nameKind
192+ return (name, nameKind, val)
193+ return $ BindingGroupDeclaration vals'
194+ ds <- go rest
195+ return $ d : ds
196+ go (d@(ExternDataDeclaration name kind) : rest) = do
197+ env <- getEnv
198+ putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (kind, ExternData) (types env) }
199+ ds <- go rest
200+ return $ d : ds
201+ go (d@(ExternDeclaration importTy name _ ty) : rest) = do
202+ rethrow (strMsg ("Error in foreign import declaration " ++ show name) <>) $ do
203+ env <- getEnv
204+ kind <- kindOf moduleName ty
205+ guardWith (strMsg "Expected kind *") $ kind == Star
206+ case M.lookup (moduleName, name) (names env) of
207+ Just _ -> throwError . strMsg $ show name ++ " is already defined"
208+ Nothing -> putEnv (env { names = M.insert (moduleName, name) (ty, Extern importTy, Defined) (names env) })
209+ ds <- go rest
210+ return $ d : ds
211+ go (d@(FixityDeclaration _ name) : rest) = do
212+ ds <- go rest
213+ env <- getEnv
214+ guardWith (strMsg ("Fixity declaration with no binding: " ++ name)) $ M.member (moduleName, Op name) $ names env
215+ return $ d : ds
216+ go (d@(ImportDeclaration importedModule _ _) : rest) = do
217+ tcds <- getTypeClassDictionaries
218+ let instances = filter (\tcd -> let Qualified (Just mn) _ = tcdName tcd in importedModule == mn) tcds
219+ addTypeClassDictionaries [ tcd { tcdName = Qualified (Just moduleName) ident, tcdType = TCDAlias (canonicalizeDictionary tcd) }
220+ | tcd <- instances
221+ , tcdExported tcd
222+ , let (Qualified _ ident) = tcdName tcd
223+ ]
224+ ds <- go rest
225+ return $ d : ds
226+ go (d@(TypeClassDeclaration pn args implies tys) : rest) = do
227+ addTypeClass moduleName pn args implies tys
228+ ds <- go rest
229+ return $ d : ds
230+ go (TypeInstanceDeclaration dictName deps className tys _ : rest) =
231+ go (ExternInstanceDeclaration dictName deps className tys : rest)
232+ go (d@(ExternInstanceDeclaration dictName deps className tys) : rest) = do
233+ mapM_ (checkTypeClassInstance moduleName) tys
234+ forM_ deps $ mapM_ (checkTypeClassInstance moduleName) . snd
235+ addTypeClassDictionaries [TypeClassDictionaryInScope (Qualified (Just moduleName) dictName) className tys (Just deps) TCDRegular isInstanceExported]
236+ ds <- go rest
237+ return $ d : ds
238+ where
239+ isInstanceExported :: Bool
240+ isInstanceExported = any exportsInstance exps
241+
242+ exportsInstance :: DeclarationRef -> Bool
243+ exportsInstance (TypeInstanceRef name) | name == dictName = True
244+ exportsInstance (PositionedDeclarationRef _ r) = exportsInstance r
245+ exportsInstance _ = False
246+
247+ go (PositionedDeclaration pos d : rest) =
248+ rethrowWithPosition pos $ do
249+ (d' : rest') <- go (d : rest)
250+ return (PositionedDeclaration pos d' : rest')
251+
252+ -- |
253+ -- This function adds the argument kinds for a type constructor so that they may appear in the externs file,
254+ -- extracted from the kind of the type constructor itself.
255+ --
256+ withKinds :: [(String, Maybe Kind)] -> Kind -> [(String, Maybe Kind)]
257+ withKinds [] _ = []
258+ withKinds (s@(_, Just _ ):ss) (FunKind _ k) = s : withKinds ss k
259+ withKinds ( (s, Nothing):ss) (FunKind k1 k2) = (s, Just k1) : withKinds ss k2
260+ withKinds _ _ = error "Invalid arguments to peelKinds"
261+
262+-- |
263+-- Type check an entire module and ensure all types and classes defined within the module that are
264+-- required by exported members are also exported.
265+--
266+typeCheckModule :: Maybe ModuleName -> Module -> Check Module
267+typeCheckModule _ (Module _ _ Nothing) = error "exports should have been elaborated"
268+typeCheckModule mainModuleName (Module mn decls (Just exps)) = do
269+ modify (\s -> s { checkCurrentModule = Just mn })
270+ decls' <- typeCheckAll mainModuleName mn exps decls
271+ forM_ exps $ \e -> do
272+ checkTypesAreExported e
273+ checkClassMembersAreExported e
274+ checkClassesAreExported e
275+ return $ Module mn decls' (Just exps)
276+ where
277+
278+ checkMemberExport :: (Show a) => String -> (Type -> [a]) -> (a -> Bool) -> DeclarationRef -> Check ()
279+ checkMemberExport thing extract test (ValueRef name) = do
280+ ty <- lookupVariable mn (Qualified (Just mn) name)
281+ case find test (extract ty) of
282+ Just hiddenType -> throwError . strMsg $
283+ "Error in module '" ++ show mn ++ "':\n\
284+ \Exporting declaration '" ++ show name ++ "' requires " ++ thing ++ " '" ++ show hiddenType ++ "' to be exported as well"
285+ Nothing -> return ()
286+ checkMemberExport _ _ _ _ = return ()
287+
288+ -- Check that all the type constructors defined in the current module that appear in member types
289+ -- have also been exported from the module
290+ checkTypesAreExported :: DeclarationRef -> Check ()
291+ checkTypesAreExported = checkMemberExport "type" findTcons isTconHidden
292+ where
293+ findTcons :: Type -> [ProperName]
294+ findTcons = everythingOnTypes (++) go
295+ where
296+ go (TypeConstructor (Qualified (Just mn') name)) | mn' == mn = [name]
297+ go _ = []
298+ isTconHidden :: ProperName -> Bool
299+ isTconHidden tyName = all go exps
300+ where
301+ go (TypeRef tyName' _) = tyName' /= tyName
302+ go _ = True
303+
304+ -- Check that all the classes defined in the current module that appear in member types have also
305+ -- been exported from the module
306+ checkClassesAreExported :: DeclarationRef -> Check ()
307+ checkClassesAreExported = checkMemberExport "class" findClasses isClassHidden
308+ where
309+ findClasses :: Type -> [ProperName]
310+ findClasses = everythingOnTypes (++) go
311+ where
312+ go (ConstrainedType cs _) = mapMaybe (extractCurrentModuleClass . fst) cs
313+ go _ = []
314+ extractCurrentModuleClass :: Qualified ProperName -> Maybe ProperName
315+ extractCurrentModuleClass (Qualified (Just mn') name) | mn == mn' = Just name
316+ extractCurrentModuleClass _ = Nothing
317+ isClassHidden :: ProperName -> Bool
318+ isClassHidden clsName = all go exps
319+ where
320+ go (TypeClassRef clsName') = clsName' /= clsName
321+ go _ = True
322+
323+ checkClassMembersAreExported :: DeclarationRef -> Check ()
324+ checkClassMembersAreExported (TypeClassRef name) = do
325+ let members = ValueRef `map` head (mapMaybe findClassMembers decls)
326+ let missingMembers = members \\ exps
327+ unless (null missingMembers) $
328+ throwError . strMsg $
329+ "Error in module '" ++ show mn ++ "':\n\
330+ \Class '" ++ show name ++ "' is exported but is missing member exports for '" ++ intercalate "', '" (map (show . runValueRef) missingMembers) ++ "'"
331+ where
332+ runValueRef :: DeclarationRef -> Ident
333+ runValueRef (ValueRef refName) = refName
334+ runValueRef _ = error "non-ValueRef passed to runValueRef"
335+ findClassMembers :: Declaration -> Maybe [Ident]
336+ findClassMembers (TypeClassDeclaration name' _ _ ds) | name == name' = Just $ map extractMemberName ds
337+ findClassMembers (PositionedDeclaration _ d) = findClassMembers d
338+ findClassMembers _ = Nothing
339+ extractMemberName :: Declaration -> Ident
340+ extractMemberName (PositionedDeclaration _ d) = extractMemberName d
341+ extractMemberName (TypeDeclaration memberName _) = memberName
342+ extractMemberName _ = error "Unexpected declaration in typeclass member list"
343+ checkClassMembersAreExported _ = return ()
src/Language/PureScript/TypeChecker/Entailment.hsnew file+217
@@ -0,0 +1,217 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.TypeChecker.Entailment
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- Type class entailment
13+--
14+-----------------------------------------------------------------------------
15+
16+module Language.PureScript.TypeChecker.Entailment (
17+ entails
18+) where
19+
20+import Data.Function (on)
21+import Data.List
22+import Data.Maybe (maybeToList)
23+import qualified Data.Map as M
24+
25+import Control.Applicative
26+import Control.Arrow (Arrow(..))
27+import Control.Monad.Error
28+
29+import Language.PureScript.AST
30+import Language.PureScript.Environment
31+import Language.PureScript.Names
32+import Language.PureScript.Pretty
33+import Language.PureScript.TypeChecker.Monad
34+import Language.PureScript.TypeChecker.Synonyms
35+import Language.PureScript.TypeChecker.Unify
36+import Language.PureScript.TypeClassDictionaries
37+import Language.PureScript.Types
38+import qualified Language.PureScript.Constants as C
39+
40+-- |
41+-- A simplified representation of expressions which are used to represent type
42+-- class dictionaries at runtime, which can be compared for equality
43+--
44+data DictionaryValue
45+ -- |
46+ -- A dictionary which is brought into scope by a local constraint
47+ --
48+ = LocalDictionaryValue (Qualified Ident)
49+ -- |
50+ -- A dictionary which is brought into scope by an instance declaration
51+ --
52+ | GlobalDictionaryValue (Qualified Ident)
53+ -- |
54+ -- A dictionary which depends on other dictionaries
55+ --
56+ | DependentDictionaryValue (Qualified Ident) [DictionaryValue]
57+ -- |
58+ -- A subclass dictionary
59+ --
60+ | SubclassDictionaryValue DictionaryValue (Qualified ProperName) Integer
61+ deriving (Show, Ord, Eq)
62+
63+-- |
64+-- Check that the current set of type class dictionaries entail the specified type class goal, and, if so,
65+-- return a type class dictionary reference.
66+--
67+entails :: Environment -> ModuleName -> [TypeClassDictionaryInScope] -> (Qualified ProperName, [Type]) -> Bool -> Check Expr
68+entails env moduleName context = solve (sortedNubBy canonicalizeDictionary (filter filterModule context))
69+ where
70+ sortedNubBy :: (Ord k) => (v -> k) -> [v] -> [v]
71+ sortedNubBy f vs = M.elems (M.fromList (map (f &&& id) vs))
72+
73+ -- Filter out type dictionaries which are in scope in the current module
74+ filterModule :: TypeClassDictionaryInScope -> Bool
75+ filterModule (TypeClassDictionaryInScope { tcdName = Qualified (Just mn) _ }) | mn == moduleName = True
76+ filterModule (TypeClassDictionaryInScope { tcdName = Qualified Nothing _ }) = True
77+ filterModule _ = False
78+
79+ solve context' (className, tys) trySuperclasses =
80+ checkOverlaps $ go trySuperclasses className tys
81+ where
82+ go trySuperclasses' className' tys' =
83+ -- Look for regular type instances
84+ [ mkDictionary (canonicalizeDictionary tcd) args
85+ | tcd <- context'
86+ -- Make sure the type class name matches the one we are trying to satisfy
87+ , className' == tcdClassName tcd
88+ -- Make sure the type unifies with the type in the type instance definition
89+ , subst <- maybeToList . (>>= verifySubstitution) . fmap concat $ zipWithM (typeHeadsAreEqual moduleName env) tys' (tcdInstanceTypes tcd)
90+ -- Solve any necessary subgoals
91+ , args <- solveSubgoals subst (tcdDependencies tcd) ] ++
92+
93+ -- Look for implementations via superclasses
94+ [ SubclassDictionaryValue suDict superclass index
95+ | trySuperclasses'
96+ , (subclassName, (args, _, implies)) <- M.toList (typeClasses env)
97+ -- Try each superclass
98+ , (index, (superclass, suTyArgs)) <- zip [0..] implies
99+ -- Make sure the type class name matches the superclass name
100+ , className' == superclass
101+ -- Make sure the types unify with the types in the superclass implication
102+ , subst <- maybeToList . (>>= verifySubstitution) . fmap concat $ zipWithM (typeHeadsAreEqual moduleName env) tys' suTyArgs
103+ -- Finally, satisfy the subclass constraint
104+ , args' <- maybeToList $ mapM ((`lookup` subst) . fst) args
105+ , suDict <- go True subclassName args' ]
106+
107+ -- Create dictionaries for subgoals which still need to be solved by calling go recursively
108+ -- E.g. the goal (Show a, Show b) => Show (Either a b) can be satisfied if the current type
109+ -- unifies with Either a b, and we can satisfy the subgoals Show a and Show b recursively.
110+ solveSubgoals :: [(String, Type)] -> Maybe [(Qualified ProperName, [Type])] -> [Maybe [DictionaryValue]]
111+ solveSubgoals _ Nothing = return Nothing
112+ solveSubgoals subst (Just subgoals) = do
113+ dict <- mapM (uncurry (go True) . second (map (replaceAllTypeVars subst))) subgoals
114+ return $ Just dict
115+ -- Make a dictionary from subgoal dictionaries by applying the correct function
116+ mkDictionary :: Qualified Ident -> Maybe [DictionaryValue] -> DictionaryValue
117+ mkDictionary fnName Nothing = LocalDictionaryValue fnName
118+ mkDictionary fnName (Just []) = GlobalDictionaryValue fnName
119+ mkDictionary fnName (Just dicts) = DependentDictionaryValue fnName dicts
120+ -- Turn a DictionaryValue into a Expr
121+ dictionaryValueToValue :: DictionaryValue -> Expr
122+ dictionaryValueToValue (LocalDictionaryValue fnName) = Var fnName
123+ dictionaryValueToValue (GlobalDictionaryValue fnName) = Var fnName
124+ dictionaryValueToValue (DependentDictionaryValue fnName dicts) = foldl App (Var fnName) (map dictionaryValueToValue dicts)
125+ dictionaryValueToValue (SubclassDictionaryValue dict superclassName index) =
126+ App (Accessor (C.__superclass_ ++ show superclassName ++ "_" ++ show index)
127+ (dictionaryValueToValue dict))
128+ valUndefined
129+ -- Ensure that a substitution is valid
130+ verifySubstitution :: [(String, Type)] -> Maybe [(String, Type)]
131+ verifySubstitution subst = do
132+ let grps = groupBy ((==) `on` fst) subst
133+ guard (all (pairwise (unifiesWith env) . map snd) grps)
134+ return $ map head grps
135+ -- |
136+ -- Check for overlapping instances
137+ --
138+ checkOverlaps :: [DictionaryValue] -> Check Expr
139+ checkOverlaps dicts =
140+ case [ (d1, d2) | d1 <- dicts, d2 <- dicts, d1 `overlapping` d2 ] of
141+ (d1, d2) : _ -> throwError . strMsg $ unlines
142+ [ "Overlapping instances found for " ++ show className ++ " " ++ unwords (map prettyPrintType tys) ++ "."
143+ , "For example:"
144+ , prettyPrintDictionaryValue d1
145+ , "and:"
146+ , prettyPrintDictionaryValue d2
147+ ]
148+ _ -> case chooseSimplestDictionaries dicts of
149+ [] -> throwError . strMsg $
150+ "No instance found for " ++ show className ++ " " ++ unwords (map prettyPrintTypeAtom tys)
151+ d : _ -> return $ dictionaryValueToValue d
152+ -- Choose the simplest DictionaryValues from a list of candidates
153+ -- The reason for this function is as follows:
154+ -- When considering overlapping instances, we don't want to consider the same dictionary
155+ -- to be an overlap of itself when obtained as a superclass of another class.
156+ -- Observing that we probably don't want to select a superclass instance when an instance
157+ -- is available directly, and that there is no way for a superclass instance to actually
158+ -- introduce an overlap that wouldn't have been there already, we simply remove dictionaries
159+ -- obtained as superclass instances if there are simpler instances available.
160+ chooseSimplestDictionaries :: [DictionaryValue] -> [DictionaryValue]
161+ chooseSimplestDictionaries ds = case filter isSimpleDictionaryValue ds of
162+ [] -> ds
163+ simple -> simple
164+ isSimpleDictionaryValue SubclassDictionaryValue{} = False
165+ isSimpleDictionaryValue (DependentDictionaryValue _ ds) = all isSimpleDictionaryValue ds
166+ isSimpleDictionaryValue _ = True
167+ -- |
168+ -- Check if two dictionaries are overlapping
169+ --
170+ -- Dictionaries which are subclass dictionaries cannot overlap, since otherwise the overlap would have
171+ -- been caught when constructing superclass dictionaries.
172+ --
173+ overlapping :: DictionaryValue -> DictionaryValue -> Bool
174+ overlapping (LocalDictionaryValue nm1) (LocalDictionaryValue nm2) | nm1 == nm2 = False
175+ overlapping (GlobalDictionaryValue nm1) (GlobalDictionaryValue nm2) | nm1 == nm2 = False
176+ overlapping (DependentDictionaryValue nm1 ds1) (DependentDictionaryValue nm2 ds2)
177+ | nm1 == nm2 = or $ zipWith overlapping ds1 ds2
178+ overlapping SubclassDictionaryValue{} _ = False
179+ overlapping _ SubclassDictionaryValue{} = False
180+ overlapping _ _ = True
181+ -- |
182+ -- Render a DictionaryValue fit for human consumption in error messages
183+ --
184+ prettyPrintDictionaryValue :: DictionaryValue -> String
185+ prettyPrintDictionaryValue = unlines . indented 0
186+ where
187+ indented n (LocalDictionaryValue _) = [spaces n ++ "Dictionary in scope"]
188+ indented n (GlobalDictionaryValue nm) = [spaces n ++ show nm]
189+ indented n (DependentDictionaryValue nm args) = (spaces n ++ show nm ++ " via") : concatMap (indented (n + 2)) args
190+ indented n (SubclassDictionaryValue sup nm _) = (spaces n ++ show nm ++ " via superclass") : indented (n + 2) sup
191+
192+ spaces n = replicate n ' ' ++ "- "
193+
194+ valUndefined :: Expr
195+ valUndefined = Var (Qualified (Just (ModuleName [ProperName C.prim])) (Ident C.undefined))
196+
197+-- |
198+-- Check whether the type heads of two types are equal (for the purposes of type class dictionary lookup),
199+-- and return a substitution from type variables to types which makes the type heads unify.
200+--
201+typeHeadsAreEqual :: ModuleName -> Environment -> Type -> Type -> Maybe [(String, Type)]
202+typeHeadsAreEqual _ _ (Skolem _ s1 _) (Skolem _ s2 _) | s1 == s2 = Just []
203+typeHeadsAreEqual _ _ t (TypeVar v) = Just [(v, t)]
204+typeHeadsAreEqual _ _ (TypeConstructor c1) (TypeConstructor c2) | c1 == c2 = Just []
205+typeHeadsAreEqual m e (TypeApp h1 t1) (TypeApp h2 t2) = (++) <$> typeHeadsAreEqual m e h1 h2 <*> typeHeadsAreEqual m e t1 t2
206+typeHeadsAreEqual m e (SaturatedTypeSynonym name args) t2 = case expandTypeSynonym' e name args of
207+ Left _ -> Nothing
208+ Right t1 -> typeHeadsAreEqual m e t1 t2
209+typeHeadsAreEqual _ _ _ _ = Nothing
210+
211+-- |
212+-- Check all values in a list pairwise match a predicate
213+--
214+pairwise :: (a -> a -> Bool) -> [a] -> Bool
215+pairwise _ [] = True
216+pairwise _ [_] = True
217+pairwise p (x : xs) = all (p x) xs && pairwise p xs
src/Language/PureScript/TypeChecker/Kinds.hsnew file+192
@@ -0,0 +1,192 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.TypeChecker.Kinds
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- This module implements the kind checker
13+--
14+-----------------------------------------------------------------------------
15+
16+{-# OPTIONS_GHC -fno-warn-orphans #-}
17+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}
18+
19+module Language.PureScript.TypeChecker.Kinds (
20+ kindOf,
21+ kindsOf,
22+ kindsOfAll
23+) where
24+
25+import Data.Maybe (fromMaybe)
26+import Data.Monoid ((<>))
27+import qualified Data.HashMap.Strict as H
28+import qualified Data.Map as M
29+
30+import Control.Applicative
31+import Control.Monad.Error
32+import Control.Monad.State
33+import Control.Monad.Unify
34+
35+import Language.PureScript.Environment
36+import Language.PureScript.Errors
37+import Language.PureScript.Kinds
38+import Language.PureScript.Names
39+import Language.PureScript.Pretty
40+import Language.PureScript.TypeChecker.Monad
41+import Language.PureScript.Types
42+
43+instance Partial Kind where
44+ unknown = KUnknown
45+ isUnknown (KUnknown u) = Just u
46+ isUnknown _ = Nothing
47+ unknowns = everythingOnKinds (++) go
48+ where
49+ go (KUnknown u) = [u]
50+ go _ = []
51+ ($?) sub = everywhereOnKinds go
52+ where
53+ go t@(KUnknown u) = fromMaybe t $ H.lookup u (runSubstitution sub)
54+ go other = other
55+
56+instance Unifiable Check Kind where
57+ KUnknown u1 =?= KUnknown u2 | u1 == u2 = return ()
58+ KUnknown u =?= k = u =:= k
59+ k =?= KUnknown u = u =:= k
60+ Star =?= Star = return ()
61+ Bang =?= Bang = return ()
62+ Row k1 =?= Row k2 = k1 =?= k2
63+ FunKind k1 k2 =?= FunKind k3 k4 = do
64+ k1 =?= k3
65+ k2 =?= k4
66+ k1 =?= k2 = UnifyT . lift . throwError . strMsg $ "Cannot unify " ++ prettyPrintKind k1 ++ " with " ++ prettyPrintKind k2 ++ "."
67+
68+-- |
69+-- Infer the kind of a single type
70+--
71+kindOf :: ModuleName -> Type -> Check Kind
72+kindOf _ ty =
73+ rethrow (mkErrorStack "Error checking kind" (Just (TypeError ty)) <>) $
74+ fmap (starIfUnknown . tidyUp) . liftUnify $ infer ty
75+ where
76+ tidyUp (k, sub) = sub $? k
77+
78+-- |
79+-- Infer the kind of a type constructor with a collection of arguments and a collection of associated data constructors
80+--
81+kindsOf :: Bool -> ModuleName -> ProperName -> [(String, Maybe Kind)] -> [Type] -> Check Kind
82+kindsOf isData moduleName name args ts = fmap tidyUp . liftUnify $ do
83+ tyCon <- fresh
84+ kargs <- replicateM (length args) fresh
85+ rest <- zipWithM freshKindVar args kargs
86+ let dict = (name, tyCon) : rest
87+ bindLocalTypeVariables moduleName dict $
88+ solveTypes isData ts kargs tyCon
89+ where
90+ tidyUp (k, sub) = starIfUnknown $ sub $? k
91+
92+freshKindVar :: (String, Maybe Kind) -> Kind -> UnifyT Kind Check (ProperName, Kind)
93+freshKindVar (arg, Nothing) kind = return (ProperName arg, kind)
94+freshKindVar (arg, Just kind') kind = do
95+ kind =?= kind'
96+ return (ProperName arg, kind')
97+
98+-- |
99+-- Simultaneously infer the kinds of several mutually recursive type constructors
100+--
101+kindsOfAll :: ModuleName -> [(ProperName, [(String, Maybe Kind)], Type)] -> [(ProperName, [(String, Maybe Kind)], [Type])] -> Check ([Kind], [Kind])
102+kindsOfAll moduleName syns tys = fmap tidyUp . liftUnify $ do
103+ synVars <- replicateM (length syns) fresh
104+ let dict = zipWith (\(name, _, _) var -> (name, var)) syns synVars
105+ bindLocalTypeVariables moduleName dict $ do
106+ tyCons <- replicateM (length tys) fresh
107+ let dict' = zipWith (\(name, _, _) tyCon -> (name, tyCon)) tys tyCons
108+ bindLocalTypeVariables moduleName dict' $ do
109+ data_ks <- zipWithM (\tyCon (_, args, ts) -> do
110+ kargs <- replicateM (length args) fresh
111+ argDict <- zipWithM freshKindVar args kargs
112+ bindLocalTypeVariables moduleName argDict $
113+ solveTypes True ts kargs tyCon) tyCons tys
114+ syn_ks <- zipWithM (\synVar (_, args, ty) -> do
115+ kargs <- replicateM (length args) fresh
116+ argDict <- zipWithM freshKindVar args kargs
117+ bindLocalTypeVariables moduleName argDict $
118+ solveTypes False [ty] kargs synVar) synVars syns
119+ return (syn_ks, data_ks)
120+ where
121+ tidyUp ((ks1, ks2), sub) = (map (starIfUnknown . (sub $?)) ks1, map (starIfUnknown . (sub $?)) ks2)
122+
123+-- |
124+-- Solve the set of kind constraints associated with the data constructors for a type constructor
125+--
126+solveTypes :: Bool -> [Type] -> [Kind] -> Kind -> UnifyT Kind Check Kind
127+solveTypes isData ts kargs tyCon = do
128+ ks <- mapM infer ts
129+ when isData $ do
130+ tyCon =?= foldr FunKind Star kargs
131+ forM_ ks $ \k -> k =?= Star
132+ unless isData $
133+ tyCon =?= foldr FunKind (head ks) kargs
134+ return tyCon
135+
136+-- |
137+-- Default all unknown kinds to the Star kind of types
138+--
139+starIfUnknown :: Kind -> Kind
140+starIfUnknown (KUnknown _) = Star
141+starIfUnknown (Row k) = Row (starIfUnknown k)
142+starIfUnknown (FunKind k1 k2) = FunKind (starIfUnknown k1) (starIfUnknown k2)
143+starIfUnknown k = k
144+
145+-- |
146+-- Infer a kind for a type
147+--
148+infer :: Type -> UnifyT Kind Check Kind
149+infer ty = rethrow (mkErrorStack "Error inferring type of value" (Just (TypeError ty)) <>) $ infer' ty
150+
151+infer' :: Type -> UnifyT Kind Check Kind
152+infer' TypeWildcard = fresh
153+infer' (TypeVar v) = do
154+ Just moduleName <- checkCurrentModule <$> get
155+ UnifyT . lift $ lookupTypeVariable moduleName (Qualified Nothing (ProperName v))
156+infer' c@(TypeConstructor v) = do
157+ env <- liftCheck getEnv
158+ case M.lookup v (types env) of
159+ Nothing -> UnifyT . lift . throwError $ mkErrorStack "Unknown type constructor" (Just (TypeError c))
160+ Just (kind, _) -> return kind
161+infer' (TypeApp t1 t2) = do
162+ k0 <- fresh
163+ k1 <- infer t1
164+ k2 <- infer t2
165+ k1 =?= FunKind k2 k0
166+ return k0
167+infer' (ForAll ident ty _) = do
168+ k1 <- fresh
169+ Just moduleName <- checkCurrentModule <$> get
170+ k2 <- bindLocalTypeVariables moduleName [(ProperName ident, k1)] $ infer ty
171+ k2 =?= Star
172+ return Star
173+infer' REmpty = do
174+ k <- fresh
175+ return $ Row k
176+infer' (RCons _ ty row) = do
177+ k1 <- infer ty
178+ k2 <- infer row
179+ k2 =?= Row k1
180+ return $ Row k1
181+infer' (ConstrainedType deps ty) = do
182+ forM_ deps $ \(className, tys) -> do
183+ _ <- infer $ foldl TypeApp (TypeConstructor className) tys
184+ return ()
185+ k <- infer ty
186+ k =?= Star
187+ return Star
188+infer' (KindedType ty k) = do
189+ k' <- infer ty
190+ k =?= k'
191+ return k'
192+infer' _ = error "Invalid argument to infer"
src/Language/PureScript/TypeChecker/Monad.hsnew file+232
@@ -0,0 +1,232 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.TypeChecker.Monad
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- Monads for type checking and type inference and associated data types
13+--
14+-----------------------------------------------------------------------------
15+
16+{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleInstances, RankNTypes,
17+ MultiParamTypeClasses, FlexibleContexts #-}
18+
19+module Language.PureScript.TypeChecker.Monad where
20+
21+import Data.Maybe
22+import qualified Data.Map as M
23+
24+import Control.Applicative
25+import Control.Monad.Error
26+import Control.Monad.State
27+import Control.Monad.Unify
28+
29+import Language.PureScript.Environment
30+import Language.PureScript.Errors
31+import Language.PureScript.Kinds
32+import Language.PureScript.Names
33+import Language.PureScript.Options
34+import Language.PureScript.TypeClassDictionaries
35+import Language.PureScript.Types
36+
37+-- |
38+-- Temporarily bind a collection of names to values
39+--
40+bindNames :: (MonadState CheckState m) => M.Map (ModuleName, Ident) (Type, NameKind, NameVisibility) -> m a -> m a
41+bindNames newNames action = do
42+ orig <- get
43+ modify $ \st -> st { checkEnv = (checkEnv st) { names = newNames `M.union` (names . checkEnv $ st) } }
44+ a <- action
45+ modify $ \st -> st { checkEnv = (checkEnv st) { names = names . checkEnv $ orig } }
46+ return a
47+
48+-- |
49+-- Temporarily bind a collection of names to types
50+--
51+bindTypes :: (MonadState CheckState m) => M.Map (Qualified ProperName) (Kind, TypeKind) -> m a -> m a
52+bindTypes newNames action = do
53+ orig <- get
54+ modify $ \st -> st { checkEnv = (checkEnv st) { types = newNames `M.union` (types . checkEnv $ st) } }
55+ a <- action
56+ modify $ \st -> st { checkEnv = (checkEnv st) { types = types . checkEnv $ orig } }
57+ return a
58+
59+-- |
60+-- Temporarily make a collection of type class dictionaries available
61+--
62+withTypeClassDictionaries :: (MonadState CheckState m) => [TypeClassDictionaryInScope] -> m a -> m a
63+withTypeClassDictionaries entries action = do
64+ orig <- get
65+ let mentries = M.fromList [ ((canonicalizeDictionary entry, mn), entry) | entry@TypeClassDictionaryInScope{ tcdName = Qualified mn _ } <- entries ]
66+ modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = (typeClassDictionaries . checkEnv $ st) `M.union` mentries } }
67+ a <- action
68+ modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = typeClassDictionaries . checkEnv $ orig } }
69+ return a
70+
71+-- |
72+-- Get the currently available list of type class dictionaries
73+--
74+getTypeClassDictionaries :: (Functor m, MonadState CheckState m) => m [TypeClassDictionaryInScope]
75+getTypeClassDictionaries = M.elems . typeClassDictionaries . checkEnv <$> get
76+
77+-- |
78+-- Temporarily bind a collection of names to local variables
79+--
80+bindLocalVariables :: (Functor m, MonadState CheckState m) => ModuleName -> [(Ident, Type, NameVisibility)] -> m a -> m a
81+bindLocalVariables moduleName bindings =
82+ bindNames (M.fromList $ flip map bindings $ \(name, ty, visibility) -> ((moduleName, name), (ty, LocalVariable, visibility)))
83+
84+-- |
85+-- Temporarily bind a collection of names to local type variables
86+--
87+bindLocalTypeVariables :: (Functor m, MonadState CheckState m) => ModuleName -> [(ProperName, Kind)] -> m a -> m a
88+bindLocalTypeVariables moduleName bindings =
89+ bindTypes (M.fromList $ flip map bindings $ \(pn, kind) -> (Qualified (Just moduleName) pn, (kind, LocalTypeVariable)))
90+
91+-- |
92+-- Update the visibility of all names to Defined
93+--
94+makeBindingGroupVisible :: (Functor m, MonadState CheckState m) => m a -> m a
95+makeBindingGroupVisible action = do
96+ orig <- get
97+ modify $ \st -> st { checkEnv = (checkEnv st) { names = M.map (\(ty, nk, _) -> (ty, nk, Defined)) (names . checkEnv $ st) } }
98+ a <- action
99+ modify $ \st -> st { checkEnv = (checkEnv st) { names = names . checkEnv $ orig } }
100+ return a
101+
102+-- |
103+-- Lookup the type of a value by name in the @Environment@
104+--
105+lookupVariable :: (Error e, Functor m, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified Ident -> m Type
106+lookupVariable currentModule (Qualified moduleName var) = do
107+ env <- getEnv
108+ case M.lookup (fromMaybe currentModule moduleName, var) (names env) of
109+ Nothing -> throwError . strMsg $ show var ++ " is undefined"
110+ Just (ty, _, _) -> return ty
111+
112+-- |
113+-- Lookup the visibility of a value by name in the @Environment@
114+--
115+getVisibility :: (Error e, Functor m, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified Ident -> m NameVisibility
116+getVisibility currentModule (Qualified moduleName var) = do
117+ env <- getEnv
118+ case M.lookup (fromMaybe currentModule moduleName, var) (names env) of
119+ Nothing -> throwError . strMsg $ show var ++ " is undefined"
120+ Just (_, _, vis) -> return vis
121+
122+-- |
123+-- Assert that a name is visible
124+--
125+checkVisibility :: (Error e, Functor m, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified Ident -> m ()
126+checkVisibility currentModule name@(Qualified _ var) = do
127+ vis <- getVisibility currentModule name
128+ case vis of
129+ Undefined -> throwError . strMsg $ show var ++ " may not be defined in the current scope."
130+ _ -> return ()
131+
132+-- |
133+-- Lookup the kind of a type by name in the @Environment@
134+--
135+lookupTypeVariable :: (Error e, Functor m, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified ProperName -> m Kind
136+lookupTypeVariable currentModule (Qualified moduleName name) = do
137+ env <- getEnv
138+ case M.lookup (Qualified (Just $ fromMaybe currentModule moduleName) name) (types env) of
139+ Nothing -> throwError . strMsg $ "Type variable " ++ show name ++ " is undefined"
140+ Just (k, _) -> return k
141+
142+-- |
143+-- State required for type checking:
144+--
145+data CheckState = CheckState {
146+ -- |
147+ -- The current @Environment@
148+ --
149+ checkEnv :: Environment
150+ -- |
151+ -- The next fresh unification variable name
152+ --
153+ , checkNextVar :: Int
154+ -- |
155+ -- The next type class dictionary name
156+ --
157+ , checkNextDictName :: Int
158+ -- |
159+ -- The current module
160+ --
161+ , checkCurrentModule :: Maybe ModuleName
162+ }
163+
164+-- |
165+-- The type checking monad, which provides the state of the type checker, and error reporting capabilities
166+--
167+newtype Check a = Check { unCheck :: StateT CheckState (Either ErrorStack) a }
168+ deriving (Functor, Monad, Applicative, Alternative, MonadPlus, MonadState CheckState, MonadError ErrorStack)
169+
170+-- |
171+-- Get the current @Environment@
172+--
173+getEnv :: (Functor m, MonadState CheckState m) => m Environment
174+getEnv = checkEnv <$> get
175+
176+-- |
177+-- Update the @Environment@
178+--
179+putEnv :: (MonadState CheckState m) => Environment -> m ()
180+putEnv env = modify (\s -> s { checkEnv = env })
181+
182+-- |
183+-- Modify the @Environment@
184+--
185+modifyEnv :: (MonadState CheckState m) => (Environment -> Environment) -> m ()
186+modifyEnv f = modify (\s -> s { checkEnv = f (checkEnv s) })
187+
188+-- |
189+-- Run a computation in the Check monad, starting with an empty @Environment@
190+--
191+runCheck :: Options mode -> Check a -> Either String (a, Environment)
192+runCheck opts = runCheck' opts initEnvironment
193+
194+-- |
195+-- Run a computation in the Check monad, failing with an error, or succeeding with a return value and the final @Environment@.
196+--
197+runCheck' :: Options mode -> Environment -> Check a -> Either String (a, Environment)
198+runCheck' opts env c = stringifyErrorStack (optionsVerboseErrors opts) $ do
199+ (a, s) <- flip runStateT (CheckState env 0 0 Nothing) $ unCheck c
200+ return (a, checkEnv s)
201+
202+-- |
203+-- Make an assertion, failing with an error message
204+--
205+guardWith :: (MonadError e m) => e -> Bool -> m ()
206+guardWith _ True = return ()
207+guardWith e False = throwError e
208+
209+-- |
210+-- Generate new type class dictionary name
211+--
212+freshDictionaryName :: Check Int
213+freshDictionaryName = do
214+ n <- checkNextDictName <$> get
215+ modify $ \s -> s { checkNextDictName = succ (checkNextDictName s) }
216+ return n
217+
218+-- |
219+-- Lift a computation in the @Check@ monad into the substitution monad.
220+--
221+liftCheck :: Check a -> UnifyT t Check a
222+liftCheck = UnifyT . lift
223+
224+-- |
225+-- Run a computation in the substitution monad, generating a return value and the final substitution.
226+--
227+liftUnify :: (Partial t) => UnifyT t Check a -> Check (a, Substitution t)
228+liftUnify unify = do
229+ st <- get
230+ (a, ust) <- runUnify (defaultUnifyState { unifyNextVar = checkNextVar st }) unify
231+ modify $ \st' -> st' { checkNextVar = unifyNextVar ust }
232+ return (a, unifyCurrentSubstitution ust)
src/Language/PureScript/TypeChecker/Rows.hsnew file+66
@@ -0,0 +1,66 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.TypeChecker.Rows
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- Functions relating to type checking for rows
13+--
14+-----------------------------------------------------------------------------
15+
16+module Language.PureScript.TypeChecker.Rows (
17+ checkDuplicateLabels
18+) where
19+
20+import Data.List
21+
22+import Control.Monad.Error
23+
24+import Language.PureScript.AST
25+import Language.PureScript.Errors
26+import Language.PureScript.TypeChecker.Monad
27+import Language.PureScript.Types
28+
29+-- |
30+-- Ensure rows do not contain duplicate labels
31+--
32+checkDuplicateLabels :: Expr -> Check ()
33+checkDuplicateLabels =
34+ let (_, f, _) = everywhereOnValuesM def go def
35+ in void . f
36+ where
37+ def :: a -> Check a
38+ def = return
39+
40+ go :: Expr -> Check Expr
41+ go e@(TypedValue _ val ty) = do
42+ checkDups ty
43+ return e
44+
45+ where
46+ checkDups :: Type -> Check ()
47+ checkDups (TypeApp t1 t2) = checkDups t1 >> checkDups t2
48+ checkDups (SaturatedTypeSynonym _ ts) = mapM_ checkDups ts
49+ checkDups (ForAll _ t _) = checkDups t
50+ checkDups (ConstrainedType args t) = do
51+ mapM_ checkDups $ concatMap snd args
52+ checkDups t
53+ checkDups r@RCons{} =
54+ let (ls, _) = rowToList r in
55+ case firstDup . sort . map fst $ ls of
56+ Just l -> throwError $ mkErrorStack ("Duplicate label " ++ show l ++ " in row") $ Just (ExprError val)
57+ Nothing -> return ()
58+ checkDups _ = return ()
59+
60+ firstDup :: (Eq a) => [a] -> Maybe a
61+ firstDup (x : xs@(x' : _))
62+ | x == x' = Just x
63+ | otherwise = firstDup xs
64+ firstDup _ = Nothing
65+
66+ go other = return other
src/Language/PureScript/TypeChecker/Skolems.hsnew file+114
@@ -0,0 +1,114 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.TypeChecker.Skolems
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- Functions relating to skolemization used during typechecking
13+--
14+-----------------------------------------------------------------------------
15+
16+module Language.PureScript.TypeChecker.Skolems (
17+ newSkolemConstant,
18+ introduceSkolemScope,
19+ newSkolemScope,
20+ skolemize,
21+ skolemizeTypesInValue,
22+ skolemEscapeCheck
23+) where
24+
25+import Data.List (nub, (\\))
26+import Data.Monoid
27+
28+import Control.Applicative
29+import Control.Monad.Error
30+import Control.Monad.Unify
31+
32+import Language.PureScript.AST
33+import Language.PureScript.Errors
34+import Language.PureScript.Pretty
35+import Language.PureScript.TypeChecker.Monad
36+import Language.PureScript.Types
37+
38+-- |
39+-- Generate a new skolem constant
40+--
41+newSkolemConstant :: UnifyT Type Check Int
42+newSkolemConstant = fresh'
43+
44+-- |
45+-- Introduce skolem scope at every occurence of a ForAll
46+--
47+introduceSkolemScope :: Type -> UnifyT Type Check Type
48+introduceSkolemScope = everywhereOnTypesM go
49+ where
50+ go (ForAll ident ty Nothing) = ForAll ident ty <$> (Just <$> newSkolemScope)
51+ go other = return other
52+
53+-- |
54+-- Generate a new skolem scope
55+--
56+newSkolemScope :: UnifyT Type Check SkolemScope
57+newSkolemScope = SkolemScope <$> fresh'
58+
59+-- |
60+-- Skolemize a type variable by replacing its instances with fresh skolem constants
61+--
62+skolemize :: String -> Int -> SkolemScope -> Type -> Type
63+skolemize ident sko scope = replaceTypeVars ident (Skolem ident sko scope)
64+
65+-- |
66+-- This function has one purpose - to skolemize type variables appearing in a
67+-- SuperClassDictionary placeholder. These type variables are somewhat unique since they are the
68+-- only example of scoped type variables.
69+--
70+skolemizeTypesInValue :: String -> Int -> SkolemScope -> Expr -> Expr
71+skolemizeTypesInValue ident sko scope = let (_, f, _) = everywhereOnValues id go id in f
72+ where
73+ go (SuperClassDictionary c ts) = SuperClassDictionary c (map (skolemize ident sko scope) ts)
74+ go other = other
75+
76+-- |
77+-- Ensure skolem variables do not escape their scope
78+--
79+skolemEscapeCheck :: Expr -> Check ()
80+skolemEscapeCheck (TypedValue False _ _) = return ()
81+skolemEscapeCheck root@TypedValue{} =
82+ -- Every skolem variable is created when a ForAll type is skolemized.
83+ -- This determines the scope of that skolem variable, which is copied from the SkolemScope
84+ -- field of the ForAll constructor.
85+ -- We traverse the tree top-down, and collect any SkolemScopes introduced by ForAlls.
86+ -- If a Skolem is encountered whose SkolemScope is not in the current list, we have found
87+ -- an escaped skolem variable.
88+ let (_, f, _, _, _) = everythingWithContextOnValues [] [] (++) def go def def def
89+ in case f root of
90+ [] -> return ()
91+ ((binding, val) : _) -> throwError $ mkErrorStack ("Rigid/skolem type variable " ++ maybe "" (("bound by " ++) . prettyPrintValue) binding ++ " has escaped.") (Just (ExprError val))
92+ where
93+ def s _ = (s, [])
94+
95+ go :: [(SkolemScope, Expr)] -> Expr -> ([(SkolemScope, Expr)], [(Maybe Expr, Expr)])
96+ go scos val@(TypedValue _ _ (ForAll _ _ (Just sco))) = ((sco, val) : scos, [])
97+ go scos val@(TypedValue _ _ ty) = case collectSkolems ty \\ map fst scos of
98+ (sco : _) -> (scos, [(findBindingScope sco, val)])
99+ _ -> (scos, [])
100+ where
101+ collectSkolems :: Type -> [SkolemScope]
102+ collectSkolems = nub . everythingOnTypes (++) collect
103+ where
104+ collect (Skolem _ _ scope) = [scope]
105+ collect _ = []
106+ go scos _ = (scos, [])
107+ findBindingScope :: SkolemScope -> Maybe Expr
108+ findBindingScope sco =
109+ let (_, f, _, _, _) = everythingOnValues mappend (const mempty) go' (const mempty) (const mempty) (const mempty)
110+ in getFirst $ f root
111+ where
112+ go' val@(TypedValue _ _ (ForAll _ _ (Just sco'))) | sco == sco' = First (Just val)
113+ go' _ = mempty
114+skolemEscapeCheck val = throwError $ mkErrorStack "Untyped value passed to skolemEscapeCheck" (Just (ExprError val))
src/Language/PureScript/TypeChecker/Subsumption.hsnew file+103
@@ -0,0 +1,103 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.TypeChecker.Subsumption
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- Subsumption checking
13+--
14+-----------------------------------------------------------------------------
15+
16+module Language.PureScript.TypeChecker.Subsumption (
17+ subsumes
18+) where
19+
20+import Data.List (sortBy)
21+import Data.Monoid
22+import Data.Ord (comparing)
23+
24+import Control.Applicative
25+import Control.Monad.Error
26+import Control.Monad.Unify
27+
28+import Language.PureScript.AST
29+import Language.PureScript.Environment
30+import Language.PureScript.Errors
31+import Language.PureScript.Pretty
32+import Language.PureScript.TypeChecker.Monad
33+import Language.PureScript.TypeChecker.Skolems
34+import Language.PureScript.TypeChecker.Synonyms
35+import Language.PureScript.TypeChecker.Unify
36+import Language.PureScript.Types
37+
38+-- |
39+-- Check whether one type subsumes another, rethrowing errors to provide a better error message
40+--
41+subsumes :: Maybe Expr -> Type -> Type -> UnifyT Type Check (Maybe Expr)
42+subsumes val ty1 ty2 = rethrow (mkErrorStack errorMessage (ExprError <$> val) <>) $ subsumes' val ty1 ty2
43+ where
44+ errorMessage = "Error checking that type "
45+ ++ prettyPrintType ty1
46+ ++ " subsumes type "
47+ ++ prettyPrintType ty2
48+
49+-- |
50+-- Check whether one type subsumes another
51+--
52+subsumes' :: Maybe Expr -> Type -> Type -> UnifyT Type Check (Maybe Expr)
53+subsumes' val (ForAll ident ty1 _) ty2 = do
54+ replaced <- replaceVarWithUnknown ident ty1
55+ subsumes val replaced ty2
56+subsumes' val ty1 (ForAll ident ty2 sco) =
57+ case sco of
58+ Just sco' -> do
59+ sko <- newSkolemConstant
60+ let sk = skolemize ident sko sco' ty2
61+ subsumes val ty1 sk
62+ Nothing -> throwError . strMsg $ "Skolem variable scope is unspecified"
63+subsumes' val (TypeApp (TypeApp f1 arg1) ret1) (TypeApp (TypeApp f2 arg2) ret2) | f1 == tyFunction && f2 == tyFunction = do
64+ _ <- subsumes Nothing arg2 arg1
65+ _ <- subsumes Nothing ret1 ret2
66+ return val
67+subsumes' val (SaturatedTypeSynonym name tyArgs) ty2 = do
68+ ty1 <- introduceSkolemScope <=< expandTypeSynonym name $ tyArgs
69+ subsumes val ty1 ty2
70+subsumes' val ty1 (SaturatedTypeSynonym name tyArgs) = do
71+ ty2 <- introduceSkolemScope <=< expandTypeSynonym name $ tyArgs
72+ subsumes val ty1 ty2
73+subsumes' val (KindedType ty1 _) ty2 =
74+ subsumes val ty1 ty2
75+subsumes' val ty1 (KindedType ty2 _) =
76+ subsumes val ty1 ty2
77+subsumes' (Just val) (ConstrainedType constraints ty1) ty2 = do
78+ dicts <- getTypeClassDictionaries
79+ subsumes' (Just $ foldl App val (map (flip (TypeClassDictionary True) dicts) constraints)) ty1 ty2
80+subsumes' val (TypeApp f1 r1) (TypeApp f2 r2) | f1 == tyObject && f2 == tyObject = do
81+ let
82+ (ts1, r1') = rowToList r1
83+ (ts2, r2') = rowToList r2
84+ ts1' = sortBy (comparing fst) ts1
85+ ts2' = sortBy (comparing fst) ts2
86+ go ts1' ts2' r1' r2'
87+ return val
88+ where
89+ go [] ts2 r1' r2' = r1' =?= rowFromList (ts2, r2')
90+ go ts1 [] r1' r2' = r2' =?= rowFromList (ts1, r1')
91+ go ((p1, ty1) : ts1) ((p2, ty2) : ts2) r1' r2'
92+ | p1 == p2 = do _ <- subsumes Nothing ty1 ty2
93+ go ts1 ts2 r1' r2'
94+ | p1 < p2 = do rest <- fresh
95+ r2' =?= RCons p1 ty1 rest
96+ go ts1 ((p2, ty2) : ts2) r1' rest
97+ | otherwise = do rest <- fresh
98+ r1' =?= RCons p2 ty2 rest
99+ go ((p1, ty1) : ts1) ts2 rest r2'
100+subsumes' val ty1 ty2@(TypeApp obj _) | obj == tyObject = subsumes val ty2 ty1
101+subsumes' val ty1 ty2 = do
102+ ty1 =?= ty2
103+ return val
src/Language/PureScript/TypeChecker/Synonyms.hsnew file+110
@@ -0,0 +1,110 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.TypeChecker.Synonyms
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- Functions for replacing fully applied type synonyms with the @SaturatedTypeSynonym@ data constructor
13+--
14+-----------------------------------------------------------------------------
15+
16+{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses #-}
17+
18+module Language.PureScript.TypeChecker.Synonyms (
19+ saturateAllTypeSynonyms,
20+ desaturateAllTypeSynonyms,
21+ replaceAllTypeSynonyms,
22+ expandAllTypeSynonyms,
23+ expandTypeSynonym,
24+ expandTypeSynonym'
25+) where
26+
27+import Data.Maybe (fromMaybe)
28+import qualified Data.Map as M
29+
30+import Control.Applicative
31+import Control.Monad.Error
32+import Control.Monad.State
33+
34+import Language.PureScript.Environment
35+import Language.PureScript.Names
36+import Language.PureScript.TypeChecker.Monad
37+import Language.PureScript.Types
38+
39+-- |
40+-- Build a type substitution for a type synonym
41+--
42+buildTypeSubstitution :: Qualified ProperName -> Int -> Type -> Either String (Maybe Type)
43+buildTypeSubstitution name n = go n []
44+ where
45+ go :: Int -> [Type] -> Type -> Either String (Maybe Type)
46+ go 0 args (TypeConstructor ctor) | name == ctor = return (Just $ SaturatedTypeSynonym ctor args)
47+ go m _ (TypeConstructor ctor) | m > 0 && name == ctor = throwError $ "Partially applied type synonym " ++ show name
48+ go m args (TypeApp f arg) = go (m - 1) (arg:args) f
49+ go _ _ _ = return Nothing
50+
51+-- |
52+-- Replace all instances of a specific type synonym with the @SaturatedTypeSynonym@ data constructor
53+--
54+saturateTypeSynonym :: Qualified ProperName -> Int -> Type -> Either String Type
55+saturateTypeSynonym name n = everywhereOnTypesTopDownM replace
56+ where
57+ replace t = fromMaybe t <$> buildTypeSubstitution name n t
58+
59+-- |
60+-- Replace all type synonyms with the @SaturatedTypeSynonym@ data constructor
61+--
62+saturateAllTypeSynonyms :: [(Qualified ProperName, Int)] -> Type -> Either String Type
63+saturateAllTypeSynonyms syns d = foldM (\result (name, n) -> saturateTypeSynonym name n result) d syns
64+
65+-- |
66+-- \"Desaturate\" @SaturatedTypeSynonym@s
67+--
68+desaturateAllTypeSynonyms :: Type -> Type
69+desaturateAllTypeSynonyms = everywhereOnTypes replaceSaturatedTypeSynonym
70+ where
71+ replaceSaturatedTypeSynonym (SaturatedTypeSynonym name args) = foldl TypeApp (TypeConstructor name) args
72+ replaceSaturatedTypeSynonym t = t
73+
74+-- |
75+-- Replace fully applied type synonyms with the @SaturatedTypeSynonym@ data constructor, which helps generate
76+-- better error messages during unification.
77+--
78+replaceAllTypeSynonyms' :: Environment -> Type -> Either String Type
79+replaceAllTypeSynonyms' env d =
80+ let
81+ syns = map (\(name, (args, _)) -> (name, length args)) . M.toList $ typeSynonyms env
82+ in
83+ saturateAllTypeSynonyms syns d
84+
85+replaceAllTypeSynonyms :: (Error e, Functor m, Monad m, MonadState CheckState m, MonadError e m) => Type -> m Type
86+replaceAllTypeSynonyms d = do
87+ env <- getEnv
88+ either (throwError . strMsg) return $ replaceAllTypeSynonyms' env d
89+
90+-- |
91+-- Replace a type synonym and its arguments with the aliased type
92+--
93+expandTypeSynonym' :: Environment -> Qualified ProperName -> [Type] -> Either String Type
94+expandTypeSynonym' env name args =
95+ case M.lookup name (typeSynonyms env) of
96+ Just (synArgs, body) -> do
97+ let repl = replaceAllTypeVars (zip (map fst synArgs) args) body
98+ replaceAllTypeSynonyms' env repl
99+ Nothing -> error "Type synonym was not defined"
100+
101+expandTypeSynonym :: (Error e, Functor m, Monad m, MonadState CheckState m, MonadError e m) => Qualified ProperName -> [Type] -> m Type
102+expandTypeSynonym name args = do
103+ env <- getEnv
104+ either (throwError . strMsg) return $ expandTypeSynonym' env name args
105+
106+expandAllTypeSynonyms :: (Error e, Functor m, Applicative m, Monad m, MonadState CheckState m, MonadError e m) => Type -> m Type
107+expandAllTypeSynonyms = everywhereOnTypesTopDownM go
108+ where
109+ go (SaturatedTypeSynonym name args) = expandTypeSynonym name args
110+ go other = return other
src/Language/PureScript/TypeChecker/Types.hsnew file+678
@@ -0,0 +1,678 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.TypeChecker.Types
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- This module implements the type checker
13+--
14+-----------------------------------------------------------------------------
15+
16+{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses #-}
17+
18+module Language.PureScript.TypeChecker.Types (
19+ typesOf
20+) where
21+
22+{-
23+ The following functions represent the corresponding type checking judgements:
24+
25+ infer
26+ Synthesize a type for a value
27+
28+ check
29+ Check a value has a given type
30+
31+ checkProperties
32+ Check an object with a given type contains specified properties
33+
34+ checkFunctionApplication
35+ Check a function of a given type returns a value of another type when applied to its arguments
36+-}
37+
38+import Data.Either (lefts, rights)
39+import Data.List
40+import Data.Maybe (fromMaybe)
41+import Data.Monoid
42+import qualified Data.Map as M
43+
44+import Control.Applicative
45+import Control.Monad.Error
46+import Control.Monad.State
47+import Control.Monad.Unify
48+
49+import Language.PureScript.AST
50+import Language.PureScript.Environment
51+import Language.PureScript.Errors
52+import Language.PureScript.Kinds
53+import Language.PureScript.Names
54+import Language.PureScript.Pretty
55+import Language.PureScript.TypeChecker.Entailment
56+import Language.PureScript.TypeChecker.Kinds
57+import Language.PureScript.TypeChecker.Monad
58+import Language.PureScript.TypeChecker.Rows
59+import Language.PureScript.TypeChecker.Skolems
60+import Language.PureScript.TypeChecker.Subsumption
61+import Language.PureScript.TypeChecker.Synonyms
62+import Language.PureScript.TypeChecker.Unify
63+import Language.PureScript.TypeClassDictionaries
64+import Language.PureScript.Types
65+import qualified Language.PureScript.Constants as C
66+
67+-- |
68+-- Infer the types of multiple mutually-recursive values, and return elaborated values including
69+-- type class dictionaries and type annotations.
70+--
71+typesOf :: Maybe ModuleName -> ModuleName -> [(Ident, Expr)] -> Check [(Ident, (Expr, Type))]
72+typesOf mainModuleName moduleName vals = do
73+ tys <- fmap tidyUp . liftUnify $ do
74+ (untyped, typed, dict, untypedDict) <- typeDictionaryForBindingGroup moduleName vals
75+ ds1 <- parU typed $ \e -> do
76+ triple@(_, (_, ty)) <- checkTypedBindingGroupElement moduleName e dict
77+ checkMain (fst e) ty
78+ return triple
79+ ds2 <- forM untyped $ \e -> do
80+ triple@(_, (_, ty)) <- typeForBindingGroupElement e dict untypedDict
81+ checkMain (fst e) ty
82+ return triple
83+ return $ ds1 ++ ds2
84+
85+ forM tys $ \(ident, (val, ty)) -> do
86+ -- Replace type class dictionary placeholders with actual dictionaries
87+ val' <- replaceTypeClassDictionaries moduleName val
88+ -- Check skolem variables did not escape their scope
89+ skolemEscapeCheck val'
90+ -- Check rows do not contain duplicate labels
91+ checkDuplicateLabels val'
92+ -- Remove type synonyms placeholders, and replace
93+ -- top-level unification variables with named type variables.
94+ let val'' = overTypes desaturateAllTypeSynonyms val'
95+ ty' = varIfUnknown . desaturateAllTypeSynonyms $ ty
96+ return (ident, (val'', ty'))
97+ where
98+ -- Apply the substitution that was returned from runUnify to both types and (type-annotated) values
99+ tidyUp (ts, sub) = map (\(i, (val, ty)) -> (i, (overTypes (sub $?) val, sub $? ty))) ts
100+ -- If --main is enabled, need to check that `main` has type Eff eff a for some eff, a
101+ checkMain nm ty = when (Just moduleName == mainModuleName && nm == Ident C.main) $ do
102+ [eff, a] <- replicateM 2 fresh
103+ ty =?= TypeApp (TypeApp (TypeConstructor (Qualified (Just (ModuleName [ProperName "Control", ProperName "Monad", ProperName "Eff"])) (ProperName "Eff"))) eff) a
104+
105+type TypeData = M.Map (ModuleName, Ident) (Type, NameKind, NameVisibility)
106+
107+type UntypedData = [(Ident, Type)]
108+
109+typeDictionaryForBindingGroup :: ModuleName -> [(Ident, Expr)] -> UnifyT Type Check ([(Ident, Expr)], [(Ident, (Expr, Type, Bool))], TypeData, UntypedData)
110+typeDictionaryForBindingGroup moduleName vals = do
111+ let
112+ -- Map each declaration to a name/value pair, with an optional type, if the declaration is typed
113+ es = map isTyped vals
114+ -- Filter the typed and untyped declarations
115+ untyped = lefts es
116+ typed = rights es
117+ -- Make a map of names to typed declarations
118+ typedDict = map (\(ident, (_, ty, _)) -> (ident, ty)) typed
119+
120+ -- Create fresh unification variables for the types of untyped declarations
121+ untypedNames <- replicateM (length untyped) fresh
122+
123+ let
124+ -- Make a map of names to the unification variables of untyped declarations
125+ untypedDict = zip (map fst untyped) untypedNames
126+ -- Create the dictionary of all name/type pairs, which will be added to the environment during type checking
127+ dict = M.fromList (map (\(ident, ty) -> ((moduleName, ident), (ty, LocalVariable, Undefined))) $ typedDict ++ untypedDict)
128+ return (untyped, typed, dict, untypedDict)
129+
130+checkTypedBindingGroupElement :: ModuleName -> (Ident, (Expr, Type, Bool)) -> TypeData -> UnifyT Type Check (Ident, (Expr, Type))
131+checkTypedBindingGroupElement moduleName (ident, (val', ty, checkType)) dict = do
132+ -- Replace type wildcards
133+ ty' <- replaceTypeWildcards ty
134+ -- Kind check
135+ kind <- liftCheck $ kindOf moduleName ty
136+ guardWith (strMsg $ "Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star
137+ -- Check the type with the new names in scope
138+ ty'' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty'
139+ val'' <- if checkType
140+ then bindNames dict $ TypedValue True <$> check val' ty'' <*> pure ty''
141+ else return (TypedValue False val' ty'')
142+ return (ident, (val'', ty''))
143+
144+typeForBindingGroupElement :: (Ident, Expr) -> TypeData -> UntypedData -> UnifyT Type Check (Ident, (Expr, Type))
145+typeForBindingGroupElement (ident, val) dict untypedDict = do
146+ -- Infer the type with the new names in scope
147+ TypedValue _ val' ty <- bindNames dict $ infer val
148+ ty =?= fromMaybe (error "name not found in dictionary") (lookup ident untypedDict)
149+ return (ident, (TypedValue True val' ty, ty))
150+
151+-- |
152+-- Check if a value contains a type annotation
153+--
154+isTyped :: (Ident, Expr) -> Either (Ident, Expr) (Ident, (Expr, Type, Bool))
155+isTyped (name, TypedValue checkType value ty) = Right (name, (value, ty, checkType))
156+isTyped (name, value) = Left (name, value)
157+
158+-- |
159+-- Map a function over type annotations appearing inside a value
160+--
161+overTypes :: (Type -> Type) -> Expr -> Expr
162+overTypes f = let (_, f', _) = everywhereOnValues id g id in f'
163+ where
164+ g :: Expr -> Expr
165+ g (TypedValue checkTy val t) = TypedValue checkTy val (f t)
166+ g (TypeClassDictionary b (nm, tys) sco) = TypeClassDictionary b (nm, map f tys) sco
167+ g other = other
168+
169+-- |
170+-- Replace type class dictionary placeholders with inferred type class dictionaries
171+--
172+replaceTypeClassDictionaries :: ModuleName -> Expr -> Check Expr
173+replaceTypeClassDictionaries mn =
174+ let (_, f, _) = everywhereOnValuesTopDownM return go return
175+ in f
176+ where
177+ go (TypeClassDictionary trySuperclasses constraint dicts) = do
178+ env <- getEnv
179+ entails env mn dicts constraint trySuperclasses
180+ go other = return other
181+
182+-- |
183+-- Check the kind of a type, failing if it is not of kind *.
184+--
185+checkTypeKind :: ModuleName -> Type -> UnifyT t Check ()
186+checkTypeKind moduleName ty = do
187+ kind <- liftCheck $ kindOf moduleName ty
188+ guardWith (strMsg $ "Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star
189+
190+-- |
191+-- Remove any ForAlls and ConstrainedType constructors in a type by introducing new unknowns
192+-- or TypeClassDictionary values.
193+--
194+-- This is necessary during type checking to avoid unifying a polymorphic type with a
195+-- unification variable.
196+--
197+instantiatePolyTypeWithUnknowns :: Expr -> Type -> UnifyT Type Check (Expr, Type)
198+instantiatePolyTypeWithUnknowns val (ForAll ident ty _) = do
199+ ty' <- replaceVarWithUnknown ident ty
200+ instantiatePolyTypeWithUnknowns val ty'
201+instantiatePolyTypeWithUnknowns val (ConstrainedType constraints ty) = do
202+ dicts <- getTypeClassDictionaries
203+ (_, ty') <- instantiatePolyTypeWithUnknowns (error "Types under a constraint cannot themselves be constrained") ty
204+ return (foldl App val (map (flip (TypeClassDictionary True) dicts) constraints), ty')
205+instantiatePolyTypeWithUnknowns val ty = return (val, ty)
206+
207+-- |
208+-- Infer a type for a value, rethrowing any error to provide a more useful error message
209+--
210+infer :: Expr -> UnifyT Type Check Expr
211+infer val = rethrow (mkErrorStack "Error inferring type of value" (Just (ExprError val)) <>) $ infer' val
212+
213+-- |
214+-- Infer a type for a value
215+--
216+infer' :: Expr -> UnifyT Type Check Expr
217+infer' v@(NumericLiteral _) = return $ TypedValue True v tyNumber
218+infer' v@(StringLiteral _) = return $ TypedValue True v tyString
219+infer' v@(BooleanLiteral _) = return $ TypedValue True v tyBoolean
220+infer' (ArrayLiteral vals) = do
221+ ts <- mapM infer vals
222+ els <- fresh
223+ forM_ ts $ \(TypedValue _ _ t) -> els =?= t
224+ return $ TypedValue True (ArrayLiteral ts) (TypeApp tyArray els)
225+infer' (ObjectLiteral ps) = do
226+ ensureNoDuplicateProperties ps
227+ ts <- mapM (infer . snd) ps
228+ let fields = zipWith (\name (TypedValue _ _ t) -> (name, t)) (map fst ps) ts
229+ ty = TypeApp tyObject $ rowFromList (fields, REmpty)
230+ return $ TypedValue True (ObjectLiteral (zip (map fst ps) ts)) ty
231+infer' (ObjectUpdate o ps) = do
232+ ensureNoDuplicateProperties ps
233+ row <- fresh
234+ newVals <- zipWith (\(name, _) t -> (name, t)) ps <$> mapM (infer . snd) ps
235+ let newTys = map (\(name, TypedValue _ _ ty) -> (name, ty)) newVals
236+ oldTys <- zip (map fst ps) <$> replicateM (length ps) fresh
237+ let oldTy = TypeApp tyObject $ rowFromList (oldTys, row)
238+ o' <- TypedValue True <$> check o oldTy <*> pure oldTy
239+ return $ TypedValue True (ObjectUpdate o' newVals) $ TypeApp tyObject $ rowFromList (newTys, row)
240+infer' (Accessor prop val) = do
241+ typed@(TypedValue _ _ objTy) <- infer val
242+ propTy <- inferProperty objTy prop
243+ case propTy of
244+ Nothing -> do
245+ field <- fresh
246+ rest <- fresh
247+ _ <- subsumes Nothing objTy (TypeApp tyObject (RCons prop field rest))
248+ return $ TypedValue True (Accessor prop typed) field
249+ Just ty -> return $ TypedValue True (Accessor prop typed) ty
250+infer' (Abs (Left arg) ret) = do
251+ ty <- fresh
252+ Just moduleName <- checkCurrentModule <$> get
253+ makeBindingGroupVisible $ bindLocalVariables moduleName [(arg, ty, Defined)] $ do
254+ body@(TypedValue _ _ bodyTy) <- infer' ret
255+ return $ TypedValue True (Abs (Left arg) body) $ function ty bodyTy
256+infer' (Abs (Right _) _) = error "Binder was not desugared"
257+infer' (App f arg) = do
258+ f'@(TypedValue _ _ ft) <- infer f
259+ (ret, app) <- checkFunctionApplication f' ft arg Nothing
260+ return $ TypedValue True app ret
261+infer' (Var var) = do
262+ Just moduleName <- checkCurrentModule <$> get
263+ checkVisibility moduleName var
264+ ty <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards <=< lookupVariable moduleName $ var
265+ case ty of
266+ ConstrainedType constraints ty' -> do
267+ dicts <- getTypeClassDictionaries
268+ return $ TypedValue True (foldl App (Var var) (map (flip (TypeClassDictionary True) dicts) constraints)) ty'
269+ _ -> return $ TypedValue True (Var var) ty
270+infer' v@(Constructor c) = do
271+ env <- getEnv
272+ case M.lookup c (dataConstructors env) of
273+ Nothing -> throwError . strMsg $ "Constructor " ++ show c ++ " is undefined"
274+ Just (_, _, ty) -> do ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty
275+ return $ TypedValue True v ty'
276+infer' (Case vals binders) = do
277+ ts <- mapM infer vals
278+ ret <- fresh
279+ binders' <- checkBinders (map (\(TypedValue _ _ t) -> t) ts) ret binders
280+ return $ TypedValue True (Case ts binders') ret
281+infer' (IfThenElse cond th el) = do
282+ cond' <- check cond tyBoolean
283+ v2@(TypedValue _ _ t2) <- infer th
284+ v3@(TypedValue _ _ t3) <- infer el
285+ (v2', v3', t) <- meet v2 v3 t2 t3
286+ return $ TypedValue True (IfThenElse cond' v2' v3') t
287+infer' (Let ds val) = do
288+ (ds', val'@(TypedValue _ _ valTy)) <- inferLetBinding [] ds val infer
289+ return $ TypedValue True (Let ds' val') valTy
290+infer' (SuperClassDictionary className tys) = do
291+ dicts <- getTypeClassDictionaries
292+ return $ TypeClassDictionary False (className, tys) dicts
293+infer' (TypedValue checkType val ty) = do
294+ Just moduleName <- checkCurrentModule <$> get
295+ checkTypeKind moduleName ty
296+ ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty
297+ val' <- if checkType then check val ty' else return val
298+ return $ TypedValue True val' ty'
299+infer' (PositionedValue pos val) = rethrowWithPosition pos $ infer' val
300+infer' _ = error "Invalid argument to infer"
301+
302+inferLetBinding :: [Declaration] -> [Declaration] -> Expr -> (Expr -> UnifyT Type Check Expr) -> UnifyT Type Check ([Declaration], Expr)
303+inferLetBinding seen [] ret j = (,) seen <$> makeBindingGroupVisible (j ret)
304+inferLetBinding seen (ValueDeclaration ident nameKind [] (Right (tv@(TypedValue checkType val ty))) : rest) ret j = do
305+ Just moduleName <- checkCurrentModule <$> get
306+ checkTypeKind moduleName ty
307+ let dict = M.singleton (moduleName, ident) (ty, nameKind, Undefined)
308+ ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty
309+ TypedValue _ val' ty'' <- if checkType then bindNames dict (check val ty') else return tv
310+ bindNames (M.singleton (moduleName, ident) (ty'', nameKind, Defined)) $ inferLetBinding (seen ++ [ValueDeclaration ident nameKind [] (Right (TypedValue checkType val' ty''))]) rest ret j
311+inferLetBinding seen (ValueDeclaration ident nameKind [] (Right val) : rest) ret j = do
312+ valTy <- fresh
313+ Just moduleName <- checkCurrentModule <$> get
314+ let dict = M.singleton (moduleName, ident) (valTy, nameKind, Undefined)
315+ TypedValue _ val' valTy' <- bindNames dict $ infer val
316+ valTy =?= valTy'
317+ bindNames (M.singleton (moduleName, ident) (valTy', nameKind, Defined)) $ inferLetBinding (seen ++ [ValueDeclaration ident nameKind [] (Right val')]) rest ret j
318+inferLetBinding seen (BindingGroupDeclaration ds : rest) ret j = do
319+ Just moduleName <- checkCurrentModule <$> get
320+ (untyped, typed, dict, untypedDict) <- typeDictionaryForBindingGroup moduleName (map (\(i, _, v) -> (i, v)) ds)
321+ ds1' <- parU typed $ \e -> checkTypedBindingGroupElement moduleName e dict
322+ ds2' <- forM untyped $ \e -> typeForBindingGroupElement e dict untypedDict
323+ let ds' = [(ident, LocalVariable, val') | (ident, (val', _)) <- ds1' ++ ds2']
324+ makeBindingGroupVisible $ bindNames dict $ inferLetBinding (seen ++ [BindingGroupDeclaration ds']) rest ret j
325+inferLetBinding seen (PositionedDeclaration pos d : ds) ret j = rethrowWithPosition pos $ do
326+ (d' : ds', val') <- inferLetBinding seen (d : ds) ret j
327+ return (PositionedDeclaration pos d' : ds', val')
328+inferLetBinding _ _ _ _ = error "Invalid argument to inferLetBinding"
329+
330+-- |
331+-- Infer the type of a property inside a record with a given type
332+--
333+inferProperty :: Type -> String -> UnifyT Type Check (Maybe Type)
334+inferProperty (TypeApp obj row) prop | obj == tyObject = do
335+ let (props, _) = rowToList row
336+ return $ lookup prop props
337+inferProperty (SaturatedTypeSynonym name args) prop = do
338+ replaced <- introduceSkolemScope <=< expandTypeSynonym name $ args
339+ inferProperty replaced prop
340+inferProperty (ForAll ident ty _) prop = do
341+ replaced <- replaceVarWithUnknown ident ty
342+ inferProperty replaced prop
343+inferProperty _ _ = return Nothing
344+
345+-- |
346+-- Infer the types of variables brought into scope by a binder
347+--
348+inferBinder :: Type -> Binder -> UnifyT Type Check (M.Map Ident Type)
349+inferBinder _ NullBinder = return M.empty
350+inferBinder val (StringBinder _) = val =?= tyString >> return M.empty
351+inferBinder val (NumberBinder _) = val =?= tyNumber >> return M.empty
352+inferBinder val (BooleanBinder _) = val =?= tyBoolean >> return M.empty
353+inferBinder val (VarBinder name) = return $ M.singleton name val
354+inferBinder val (ConstructorBinder ctor binders) = do
355+ env <- getEnv
356+ case M.lookup ctor (dataConstructors env) of
357+ Just (_, _, ty) -> do
358+ (_, fn) <- instantiatePolyTypeWithUnknowns (error "Data constructor types cannot contain constraints") ty
359+ fn' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ fn
360+ go binders fn'
361+ where
362+ go [] ty' = do
363+ _ <- subsumes Nothing val ty'
364+ return M.empty
365+ go (binder : binders') (TypeApp (TypeApp t obj) ret) | t == tyFunction =
366+ M.union <$> inferBinder obj binder <*> go binders' ret
367+ go _ _ = throwError . strMsg $ "Wrong number of arguments to constructor " ++ show ctor
368+ _ -> throwError . strMsg $ "Constructor " ++ show ctor ++ " is not defined"
369+inferBinder val (ObjectBinder props) = do
370+ row <- fresh
371+ rest <- fresh
372+ m1 <- inferRowProperties row rest props
373+ val =?= TypeApp tyObject row
374+ return m1
375+ where
376+ inferRowProperties :: Type -> Type -> [(String, Binder)] -> UnifyT Type Check (M.Map Ident Type)
377+ inferRowProperties nrow row [] = nrow =?= row >> return M.empty
378+ inferRowProperties nrow row ((name, binder):binders) = do
379+ propTy <- fresh
380+ m1 <- inferBinder propTy binder
381+ m2 <- inferRowProperties nrow (RCons name propTy row) binders
382+ return $ m1 `M.union` m2
383+inferBinder val (ArrayBinder binders) = do
384+ el <- fresh
385+ m1 <- M.unions <$> mapM (inferBinder el) binders
386+ val =?= TypeApp tyArray el
387+ return m1
388+inferBinder val (ConsBinder headBinder tailBinder) = do
389+ el <- fresh
390+ m1 <- inferBinder el headBinder
391+ m2 <- inferBinder val tailBinder
392+ val =?= TypeApp tyArray el
393+ return $ m1 `M.union` m2
394+inferBinder val (NamedBinder name binder) = do
395+ m <- inferBinder val binder
396+ return $ M.insert name val m
397+inferBinder val (PositionedBinder pos binder) =
398+ rethrowWithPosition pos $ inferBinder val binder
399+
400+-- |
401+-- Check the types of the return values in a set of binders in a case statement
402+--
403+checkBinders :: [Type] -> Type -> [CaseAlternative] -> UnifyT Type Check [CaseAlternative]
404+checkBinders _ _ [] = return []
405+checkBinders nvals ret (CaseAlternative binders result : bs) = do
406+ guardWith (strMsg "Overlapping binders in case statement") $
407+ let ns = concatMap binderNames binders in length (nub ns) == length ns
408+ Just moduleName <- checkCurrentModule <$> get
409+ m1 <- M.unions <$> zipWithM inferBinder nvals binders
410+ r <- bindLocalVariables moduleName [ (name, ty, Defined) | (name, ty) <- M.toList m1 ] $
411+ CaseAlternative binders <$>
412+ case result of
413+ Left gs -> do
414+ gs' <- forM gs $ \(grd, val) -> do
415+ grd' <- check grd tyBoolean
416+ val' <- TypedValue True <$> check val ret <*> pure ret
417+ return (grd', val')
418+ return $ Left gs'
419+ Right val -> do
420+ val' <- TypedValue True <$> check val ret <*> pure ret
421+ return $ Right val'
422+ rs <- checkBinders nvals ret bs
423+ return $ r : rs
424+
425+-- |
426+-- Check the type of a value, rethrowing errors to provide a better error message
427+--
428+check :: Expr -> Type -> UnifyT Type Check Expr
429+check val ty = rethrow (mkErrorStack errorMessage (Just (ExprError val)) <>) $ check' val ty
430+ where
431+ errorMessage =
432+ "Error checking type of term " ++
433+ prettyPrintValue val ++
434+ " against type " ++
435+ prettyPrintType ty
436+
437+-- |
438+-- Check the type of a value
439+--
440+check' :: Expr -> Type -> UnifyT Type Check Expr
441+check' val (ForAll ident ty _) = do
442+ scope <- newSkolemScope
443+ sko <- newSkolemConstant
444+ let sk = skolemize ident sko scope ty
445+ let skVal = skolemizeTypesInValue ident sko scope val
446+ val' <- check skVal sk
447+ return $ TypedValue True val' (ForAll ident ty (Just scope))
448+check' val t@(ConstrainedType constraints ty) = do
449+ dictNames <- forM constraints $ \(Qualified _ (ProperName className), _) -> do
450+ n <- liftCheck freshDictionaryName
451+ return $ Ident $ "__dict_" ++ className ++ "_" ++ show n
452+ val' <- makeBindingGroupVisible $ withTypeClassDictionaries (zipWith (\name (className, instanceTy) ->
453+ TypeClassDictionaryInScope name className instanceTy Nothing TCDRegular False) (map (Qualified Nothing) dictNames)
454+ constraints) $ check val ty
455+ return $ TypedValue True (foldr (Abs . Left) val' dictNames) t
456+check' val (SaturatedTypeSynonym name args) = do
457+ ty <- introduceSkolemScope <=< expandTypeSynonym name $ args
458+ check val ty
459+check' val u@(TUnknown _) = do
460+ val'@(TypedValue _ _ ty) <- infer val
461+ -- Don't unify an unknown with an inferred polytype
462+ (val'', ty') <- instantiatePolyTypeWithUnknowns val' ty
463+ ty' =?= u
464+ return $ TypedValue True val'' ty'
465+check' v@(NumericLiteral _) t | t == tyNumber =
466+ return $ TypedValue True v t
467+check' v@(StringLiteral _) t | t == tyString =
468+ return $ TypedValue True v t
469+check' v@(BooleanLiteral _) t | t == tyBoolean =
470+ return $ TypedValue True v t
471+check' (ArrayLiteral vals) t@(TypeApp a ty) = do
472+ a =?= tyArray
473+ array <- ArrayLiteral <$> forM vals (`check` ty)
474+ return $ TypedValue True array t
475+check' (Abs (Left arg) ret) ty@(TypeApp (TypeApp t argTy) retTy) | t == tyFunction = do
476+ Just moduleName <- checkCurrentModule <$> get
477+ ret' <- makeBindingGroupVisible $ bindLocalVariables moduleName [(arg, argTy, Defined)] $ check ret retTy
478+ return $ TypedValue True (Abs (Left arg) ret') ty
479+check' (Abs (Right _) _) _ = error "Binder was not desugared"
480+check' (App f arg) ret = do
481+ f'@(TypedValue _ _ ft) <- infer f
482+ (_, app) <- checkFunctionApplication f' ft arg (Just ret)
483+ return $ TypedValue True app ret
484+check' v@(Var var) ty = do
485+ Just moduleName <- checkCurrentModule <$> get
486+ checkVisibility moduleName var
487+ repl <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< lookupVariable moduleName $ var
488+ ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty
489+ v' <- subsumes (Just v) repl ty'
490+ case v' of
491+ Nothing -> throwError . strMsg $ "Unable to check type subsumption"
492+ Just v'' -> return $ TypedValue True v'' ty'
493+check' (SuperClassDictionary className tys) _ = do
494+ {-
495+ -- Here, we replace a placeholder for a superclass dictionary with a regular
496+ -- TypeClassDictionary placeholder. The reason we do this is that it is necessary to have the
497+ -- correct super instance dictionaries in scope, and these are not available when the type class
498+ -- declaration gets desugared.
499+ --
500+ -- Note also that the first argument to TypeClassDictionary is False, meaning we _do not_ want
501+ -- to consider superclass instances when searching for this dictionary - doing so might lead
502+ -- to traversing a cycle in the instance graph.
503+ -}
504+ dicts <- getTypeClassDictionaries
505+ return $ TypeClassDictionary False (className, tys) dicts
506+check' (TypedValue checkType val ty1) ty2 = do
507+ Just moduleName <- checkCurrentModule <$> get
508+ checkTypeKind moduleName ty1
509+ ty1' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty1
510+ ty2' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty2
511+ val' <- subsumes (Just val) ty1' ty2'
512+ case val' of
513+ Nothing -> throwError . strMsg $ "Unable to check type subsumption"
514+ Just val'' -> do
515+ val''' <- if checkType then check val'' ty2' else return val''
516+ return $ TypedValue checkType (TypedValue True val''' ty1') ty2'
517+check' (Case vals binders) ret = do
518+ vals' <- mapM infer vals
519+ let ts = map (\(TypedValue _ _ t) -> t) vals'
520+ binders' <- checkBinders ts ret binders
521+ return $ TypedValue True (Case vals' binders') ret
522+check' (IfThenElse cond th el) ty = do
523+ cond' <- check cond tyBoolean
524+ th' <- check th ty
525+ el' <- check el ty
526+ return $ TypedValue True (IfThenElse cond' th' el') ty
527+check' (ObjectLiteral ps) t@(TypeApp obj row) | obj == tyObject = do
528+ ensureNoDuplicateProperties ps
529+ ps' <- checkProperties ps row False
530+ return $ TypedValue True (ObjectLiteral ps') t
531+check' (TypeClassDictionaryConstructorApp name ps) t = do
532+ ps' <- check' ps t
533+ return $ TypedValue True (TypeClassDictionaryConstructorApp name ps') t
534+check' (ObjectUpdate obj ps) t@(TypeApp o row) | o == tyObject = do
535+ ensureNoDuplicateProperties ps
536+ -- We need to be careful to avoid duplicate labels here.
537+ -- We check _obj_ agaist the type _t_ with the types in _ps_ replaced with unknowns.
538+ let (propsToCheck, rest) = rowToList row
539+ (removedProps, remainingProps) = partition (\(p, _) -> p `elem` map fst ps) propsToCheck
540+ us <- zip (map fst removedProps) <$> replicateM (length ps) fresh
541+ obj' <- check obj (TypeApp tyObject (rowFromList (us ++ remainingProps, rest)))
542+ ps' <- checkProperties ps row True
543+ return $ TypedValue True (ObjectUpdate obj' ps') t
544+check' (Accessor prop val) ty = do
545+ rest <- fresh
546+ val' <- check val (TypeApp tyObject (RCons prop ty rest))
547+ return $ TypedValue True (Accessor prop val') ty
548+check' (Constructor c) ty = do
549+ env <- getEnv
550+ case M.lookup c (dataConstructors env) of
551+ Nothing -> throwError . strMsg $ "Constructor " ++ show c ++ " is undefined"
552+ Just (_, _, ty1) -> do
553+ repl <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty1
554+ _ <- subsumes Nothing repl ty
555+ return $ TypedValue True (Constructor c) ty
556+check' (Let ds val) ty = do
557+ (ds', val') <- inferLetBinding [] ds val (`check` ty)
558+ return $ TypedValue True (Let ds' val') ty
559+check' val ty | containsTypeSynonyms ty = do
560+ ty' <- introduceSkolemScope <=< expandAllTypeSynonyms <=< replaceTypeWildcards $ ty
561+ check val ty'
562+check' val kt@(KindedType ty kind) = do
563+ guardWith (strMsg $ "Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star
564+ val' <- check' val ty
565+ return $ TypedValue True val' kt
566+check' (PositionedValue pos val) ty =
567+ rethrowWithPosition pos $ check val ty
568+check' val ty = throwError $ mkErrorStack ("Expr does not have type " ++ prettyPrintType ty) (Just (ExprError val))
569+
570+containsTypeSynonyms :: Type -> Bool
571+containsTypeSynonyms = everythingOnTypes (||) go where
572+ go (SaturatedTypeSynonym _ _) = True
573+ go _ = False
574+
575+-- |
576+-- Check the type of a collection of named record fields
577+--
578+-- The @lax@ parameter controls whether or not every record member has to be provided. For object updates, this is not the case.
579+--
580+checkProperties :: [(String, Expr)] -> Type -> Bool -> UnifyT Type Check [(String, Expr)]
581+checkProperties ps row lax = let (ts, r') = rowToList row in go ps ts r' where
582+ go [] [] REmpty = return []
583+ go [] [] u@(TUnknown _) = do u =?= REmpty
584+ return []
585+ go [] [] Skolem{} | lax = return []
586+ go [] ((p, _): _) _ | lax = return []
587+ | otherwise = throwError $ mkErrorStack ("Object does not have property " ++ p) (Just (ExprError (ObjectLiteral ps)))
588+ go ((p,_):_) [] REmpty = throwError $ mkErrorStack ("Property " ++ p ++ " is not present in closed object type " ++ prettyPrintRow row) (Just (ExprError (ObjectLiteral ps)))
589+ go ((p,v):ps') [] u@(TUnknown _) = do
590+ v'@(TypedValue _ _ ty) <- infer v
591+ rest <- fresh
592+ u =?= RCons p ty rest
593+ ps'' <- go ps' [] rest
594+ return $ (p, v') : ps''
595+ go ((p,v):ps') ts r =
596+ case lookup p ts of
597+ Nothing -> do
598+ v'@(TypedValue _ _ ty) <- infer v
599+ rest <- fresh
600+ r =?= RCons p ty rest
601+ ps'' <- go ps' ts rest
602+ return $ (p, v') : ps''
603+ Just ty -> do
604+ v' <- check v ty
605+ ps'' <- go ps' (delete (p, ty) ts) r
606+ return $ (p, v') : ps''
607+ go _ _ _ = throwError $ mkErrorStack ("Object does not have type " ++ prettyPrintType (TypeApp tyObject row)) (Just (ExprError (ObjectLiteral ps)))
608+
609+-- |
610+-- Check the type of a function application, rethrowing errors to provide a better error message
611+--
612+checkFunctionApplication :: Expr -> Type -> Expr -> Maybe Type -> UnifyT Type Check (Type, Expr)
613+checkFunctionApplication fn fnTy arg ret = rethrow (mkErrorStack errorMessage (Just (ExprError fn)) <>) $ do
614+ subst <- unifyCurrentSubstitution <$> UnifyT get
615+ checkFunctionApplication' fn (subst $? fnTy) arg (($?) subst <$> ret)
616+ where
617+ errorMessage = "Error applying function of type "
618+ ++ prettyPrintType fnTy
619+ ++ " to argument " ++ prettyPrintValue arg
620+
621+-- |
622+-- Check the type of a function application
623+--
624+checkFunctionApplication' :: Expr -> Type -> Expr -> Maybe Type -> UnifyT Type Check (Type, Expr)
625+checkFunctionApplication' fn (TypeApp (TypeApp tyFunction' argTy) retTy) arg ret = do
626+ tyFunction' =?= tyFunction
627+ arg' <- check arg argTy
628+ case ret of
629+ Nothing -> return (retTy, App fn arg')
630+ Just ret' -> do
631+ Just app' <- subsumes (Just (App fn arg')) retTy ret'
632+ return (retTy, app')
633+checkFunctionApplication' fn (ForAll ident ty _) arg ret = do
634+ replaced <- replaceVarWithUnknown ident ty
635+ checkFunctionApplication fn replaced arg ret
636+checkFunctionApplication' fn u@(TUnknown _) arg ret = do
637+ arg' <- do
638+ TypedValue _ arg' t <- infer arg
639+ (arg'', t') <- instantiatePolyTypeWithUnknowns arg' t
640+ return $ TypedValue True arg'' t'
641+ let ty = (\(TypedValue _ _ t) -> t) arg'
642+ ret' <- maybe fresh return ret
643+ u =?= function ty ret'
644+ return (ret', App fn arg')
645+checkFunctionApplication' fn (SaturatedTypeSynonym name tyArgs) arg ret = do
646+ ty <- introduceSkolemScope <=< expandTypeSynonym name $ tyArgs
647+ checkFunctionApplication fn ty arg ret
648+checkFunctionApplication' fn (KindedType ty _) arg ret =
649+ checkFunctionApplication fn ty arg ret
650+checkFunctionApplication' fn (ConstrainedType constraints fnTy) arg ret = do
651+ dicts <- getTypeClassDictionaries
652+ checkFunctionApplication' (foldl App fn (map (flip (TypeClassDictionary True) dicts) constraints)) fnTy arg ret
653+checkFunctionApplication' fn fnTy dict@TypeClassDictionary{} _ =
654+ return (fnTy, App fn dict)
655+checkFunctionApplication' _ fnTy arg _ = throwError . strMsg $ "Cannot apply a function of type "
656+ ++ prettyPrintType fnTy
657+ ++ " to argument " ++ prettyPrintValue arg
658+
659+-- |
660+-- Compute the meet of two types, i.e. the most general type which both types subsume.
661+-- TODO: handle constrained types
662+--
663+meet :: Expr -> Expr -> Type -> Type -> UnifyT Type Check (Expr, Expr, Type)
664+meet e1 e2 (ForAll ident t1 _) t2 = do
665+ t1' <- replaceVarWithUnknown ident t1
666+ meet e1 e2 t1' t2
667+meet e1 e2 t1 (ForAll ident t2 _) = do
668+ t2' <- replaceVarWithUnknown ident t2
669+ meet e1 e2 t1 t2'
670+meet e1 e2 t1 t2 = do
671+ t1 =?= t2
672+ return (e1, e2, t1)
673+
674+-- |
675+-- Ensure a set of property names and value does not contain duplicate labels
676+--
677+ensureNoDuplicateProperties :: (Error e, MonadError e m) => [(String, Expr)] -> m ()
678+ensureNoDuplicateProperties ps = guardWith (strMsg "Duplicate property names") $ length (nub . map fst $ ps) == length ps
src/Language/PureScript/TypeChecker/Unify.hsnew file+184
@@ -0,0 +1,184 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.TypeChecker.Unify
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- Functions and instances relating to unification
13+--
14+-----------------------------------------------------------------------------
15+
16+{-# OPTIONS_GHC -fno-warn-orphans #-}
17+{-# LANGUAGE FlexibleInstances, FlexibleContexts, MultiParamTypeClasses #-}
18+
19+module Language.PureScript.TypeChecker.Unify (
20+ unifyTypes,
21+ unifyRows,
22+ unifiesWith,
23+ replaceVarWithUnknown,
24+ replaceTypeWildcards,
25+ varIfUnknown
26+) where
27+
28+import Data.List (nub, sort)
29+import Data.Maybe (fromMaybe)
30+import Data.Monoid
31+import qualified Data.HashMap.Strict as H
32+
33+import Control.Monad.Error
34+import Control.Monad.Unify
35+
36+import Language.PureScript.Environment
37+import Language.PureScript.Errors
38+import Language.PureScript.Pretty
39+import Language.PureScript.TypeChecker.Monad
40+import Language.PureScript.TypeChecker.Skolems
41+import Language.PureScript.TypeChecker.Synonyms
42+import Language.PureScript.Types
43+
44+instance Partial Type where
45+ unknown = TUnknown
46+ isUnknown (TUnknown u) = Just u
47+ isUnknown _ = Nothing
48+ unknowns = everythingOnTypes (++) go
49+ where
50+ go (TUnknown u) = [u]
51+ go _ = []
52+ ($?) sub = everywhereOnTypes go
53+ where
54+ go t@(TUnknown u) = fromMaybe t $ H.lookup u (runSubstitution sub)
55+ go other = other
56+
57+instance Unifiable Check Type where
58+ (=?=) = unifyTypes
59+
60+-- |
61+-- Unify two types, updating the current substitution
62+--
63+unifyTypes :: Type -> Type -> UnifyT Type Check ()
64+unifyTypes t1 t2 = rethrow (mkErrorStack ("Error unifying type " ++ prettyPrintType t1 ++ " with type " ++ prettyPrintType t2) Nothing <>) $
65+ unifyTypes' t1 t2
66+ where
67+ unifyTypes' (TUnknown u1) (TUnknown u2) | u1 == u2 = return ()
68+ unifyTypes' (TUnknown u) t = u =:= t
69+ unifyTypes' t (TUnknown u) = u =:= t
70+ unifyTypes' (SaturatedTypeSynonym name args) ty = do
71+ ty1 <- introduceSkolemScope <=< expandTypeSynonym name $ args
72+ ty1 `unifyTypes` ty
73+ unifyTypes' ty s@(SaturatedTypeSynonym _ _) = s `unifyTypes` ty
74+ unifyTypes' (ForAll ident1 ty1 sc1) (ForAll ident2 ty2 sc2) =
75+ case (sc1, sc2) of
76+ (Just sc1', Just sc2') -> do
77+ sko <- newSkolemConstant
78+ let sk1 = skolemize ident1 sko sc1' ty1
79+ let sk2 = skolemize ident2 sko sc2' ty2
80+ sk1 `unifyTypes` sk2
81+ _ -> error "Skolemized type variable was not given a scope"
82+ unifyTypes' (ForAll ident ty1 (Just sc)) ty2 = do
83+ sko <- newSkolemConstant
84+ let sk = skolemize ident sko sc ty1
85+ sk `unifyTypes` ty2
86+ unifyTypes' ForAll{} _ = throwError . strMsg $ "Skolem variable scope is unspecified"
87+ unifyTypes' ty f@ForAll{} = f `unifyTypes` ty
88+ unifyTypes' (TypeVar v1) (TypeVar v2) | v1 == v2 = return ()
89+ unifyTypes' (TypeConstructor c1) (TypeConstructor c2) =
90+ guardWith (strMsg ("Cannot unify " ++ show c1 ++ " with " ++ show c2 ++ ".")) (c1 == c2)
91+ unifyTypes' (TypeApp t3 t4) (TypeApp t5 t6) = do
92+ t3 `unifyTypes` t5
93+ t4 `unifyTypes` t6
94+ unifyTypes' (Skolem _ s1 _) (Skolem _ s2 _) | s1 == s2 = return ()
95+ unifyTypes' (KindedType ty1 _) ty2 = ty1 `unifyTypes` ty2
96+ unifyTypes' ty1 (KindedType ty2 _) = ty1 `unifyTypes` ty2
97+ unifyTypes' r1@RCons{} r2 = unifyRows r1 r2
98+ unifyTypes' r1 r2@RCons{} = unifyRows r1 r2
99+ unifyTypes' r1@REmpty r2 = unifyRows r1 r2
100+ unifyTypes' r1 r2@REmpty = unifyRows r1 r2
101+ unifyTypes' t@(ConstrainedType _ _) _ = throwError . strMsg $ "Attempted to unify a constrained type " ++ prettyPrintType t ++ " with another type."
102+ unifyTypes' t3 t4@(ConstrainedType _ _) = unifyTypes' t4 t3
103+ unifyTypes' t3 t4 = throwError . strMsg $ "Cannot unify " ++ prettyPrintType t3 ++ " with " ++ prettyPrintType t4 ++ "."
104+
105+-- |
106+-- Unify two rows, updating the current substitution
107+--
108+-- Common labels are first identified, and unified. Remaining labels and types are unified with a
109+-- trailing row unification variable, if appropriate, otherwise leftover labels result in a unification
110+-- error.
111+--
112+unifyRows :: Type -> Type -> UnifyT Type Check ()
113+unifyRows r1 r2 =
114+ let
115+ (s1, r1') = rowToList r1
116+ (s2, r2') = rowToList r2
117+ int = [ (t1, t2) | (name, t1) <- s1, (name', t2) <- s2, name == name' ]
118+ sd1 = [ (name, t1) | (name, t1) <- s1, name `notElem` map fst s2 ]
119+ sd2 = [ (name, t2) | (name, t2) <- s2, name `notElem` map fst s1 ]
120+ in do
121+ forM_ int (uncurry (=?=))
122+ unifyRows' sd1 r1' sd2 r2'
123+ where
124+ unifyRows' :: [(String, Type)] -> Type -> [(String, Type)] -> Type -> UnifyT Type Check ()
125+ unifyRows' [] (TUnknown u) sd r = u =:= rowFromList (sd, r)
126+ unifyRows' sd r [] (TUnknown u) = u =:= rowFromList (sd, r)
127+ unifyRows' sd1 (TUnknown u1) sd2 (TUnknown u2) = do
128+ forM_ sd1 $ \(_, t) -> occursCheck u2 t
129+ forM_ sd2 $ \(_, t) -> occursCheck u1 t
130+ rest <- fresh
131+ u1 =:= rowFromList (sd2, rest)
132+ u2 =:= rowFromList (sd1, rest)
133+ unifyRows' [] REmpty [] REmpty = return ()
134+ unifyRows' [] (TypeVar v1) [] (TypeVar v2) | v1 == v2 = return ()
135+ unifyRows' [] (Skolem _ s1 _) [] (Skolem _ s2 _) | s1 == s2 = return ()
136+ unifyRows' sd3 r3 sd4 r4 = throwError . strMsg $ "Cannot unify (" ++ prettyPrintRow (rowFromList (sd3, r3)) ++ ") with (" ++ prettyPrintRow (rowFromList (sd4, r4)) ++ ")"
137+
138+-- |
139+-- Check that two types unify
140+--
141+unifiesWith :: Environment -> Type -> Type -> Bool
142+unifiesWith _ (TUnknown u1) (TUnknown u2) | u1 == u2 = True
143+unifiesWith _ (Skolem _ s1 _) (Skolem _ s2 _) | s1 == s2 = True
144+unifiesWith _ (TypeVar v1) (TypeVar v2) | v1 == v2 = True
145+unifiesWith _ (TypeConstructor c1) (TypeConstructor c2) | c1 == c2 = True
146+unifiesWith e (TypeApp h1 t1) (TypeApp h2 t2) = unifiesWith e h1 h2 && unifiesWith e t1 t2
147+unifiesWith e (SaturatedTypeSynonym name args) t2 =
148+ case expandTypeSynonym' e name args of
149+ Left _ -> False
150+ Right t1 -> unifiesWith e t1 t2
151+unifiesWith e t1 t2@(SaturatedTypeSynonym _ _) = unifiesWith e t2 t1
152+unifiesWith _ _ _ = False
153+
154+-- |
155+-- Replace a single type variable with a new unification variable
156+--
157+replaceVarWithUnknown :: String -> Type -> UnifyT Type Check Type
158+replaceVarWithUnknown ident ty = do
159+ tu <- fresh
160+ return $ replaceTypeVars ident tu ty
161+
162+-- |
163+-- Replace type wildcards with unknowns
164+--
165+replaceTypeWildcards :: Type -> UnifyT t Check Type
166+replaceTypeWildcards = everywhereOnTypesM replace
167+ where
168+ replace TypeWildcard = do
169+ u <- fresh'
170+ return $ TUnknown u
171+ replace other = return other
172+
173+-- |
174+-- Replace outermost unsolved unification variables with named type variables
175+--
176+varIfUnknown :: Type -> Type
177+varIfUnknown ty =
178+ let unks = nub $ unknowns ty
179+ toName = (:) 't' . show
180+ ty' = everywhereOnTypes typeToVar ty
181+ typeToVar :: Type -> Type
182+ typeToVar (TUnknown u) = TypeVar (toName u)
183+ typeToVar t = t
184+ in mkForAll (sort . map toName $ unks) ty'
src/Language/PureScript/TypeClassDictionaries.hsnew file+73
@@ -0,0 +1,73 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.TypeClassDictionaries
4+-- Copyright : (c) 2014 Phil Freeman
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+--
13+-----------------------------------------------------------------------------
14+
15+{-# LANGUAGE DeriveDataTypeable #-}
16+
17+module Language.PureScript.TypeClassDictionaries where
18+
19+import Data.Data
20+
21+import Language.PureScript.Names
22+import Language.PureScript.Types
23+
24+-- |
25+-- Data representing a type class dictionary which is in scope
26+--
27+data TypeClassDictionaryInScope
28+ = TypeClassDictionaryInScope {
29+ -- |
30+ -- The identifier with which the dictionary can be accessed at runtime
31+ --
32+ tcdName :: Qualified Ident
33+ -- |
34+ -- The name of the type class to which this type class instance applies
35+ --
36+ , tcdClassName :: Qualified ProperName
37+ -- |
38+ -- The types to which this type class instance applies
39+ --
40+ , tcdInstanceTypes :: [Type]
41+ -- |
42+ -- Type class dependencies which must be satisfied to construct this dictionary
43+ --
44+ , tcdDependencies :: Maybe [(Qualified ProperName, [Type])]
45+ -- |
46+ -- The type of this dictionary
47+ --
48+ , tcdType :: TypeClassDictionaryType
49+ -- |
50+ -- Is this instance exported by its module?
51+ --
52+ , tcdExported :: Bool
53+ } deriving (Show, Data, Typeable)
54+
55+-- |
56+-- The type of a type class dictionary
57+--
58+data TypeClassDictionaryType
59+ -- |
60+ -- A regular type class dictionary
61+ --
62+ = TCDRegular
63+ -- |
64+ -- A type class dictionary which is an alias for an imported dictionary from another module
65+ --
66+ | TCDAlias (Qualified Ident) deriving (Show, Eq, Data, Typeable)
67+
68+-- |
69+-- Find the original dictionary which a type class dictionary in scope refers to
70+--
71+canonicalizeDictionary :: TypeClassDictionaryInScope -> Qualified Ident
72+canonicalizeDictionary (TypeClassDictionaryInScope { tcdType = TCDRegular, tcdName = nm }) = nm
73+canonicalizeDictionary (TypeClassDictionaryInScope { tcdType = TCDAlias nm }) = nm
src/Language/PureScript/Types.hsnew file+299
@@ -0,0 +1,299 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.Types
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- Data types for types
13+--
14+-----------------------------------------------------------------------------
15+
16+{-# LANGUAGE DeriveDataTypeable #-}
17+
18+module Language.PureScript.Types where
19+
20+import Data.Data
21+import Data.List (nub)
22+
23+import Control.Monad.Unify
24+import Control.Arrow (second)
25+import Control.Applicative
26+import Control.Monad ((<=<))
27+
28+import Language.PureScript.Names
29+import Language.PureScript.Kinds
30+import Language.PureScript.Traversals
31+
32+-- |
33+-- An identifier for the scope of a skolem variable
34+--
35+newtype SkolemScope = SkolemScope { runSkolemScope :: Int } deriving (Show, Eq, Ord, Data, Typeable)
36+
37+-- |
38+-- The type of types
39+--
40+data Type
41+ -- |
42+ -- A unification variable of type Type
43+ --
44+ = TUnknown Unknown
45+ -- |
46+ -- A named type variable
47+ --
48+ | TypeVar String
49+ -- |
50+ -- A type wildcard, as would appear in a partial type synonym
51+ --
52+ | TypeWildcard
53+ -- |
54+ -- A type constructor
55+ --
56+ | TypeConstructor (Qualified ProperName)
57+ -- |
58+ -- A type application
59+ --
60+ | TypeApp Type Type
61+ -- |
62+ -- A type synonym which is \"saturated\", i.e. fully applied
63+ --
64+ | SaturatedTypeSynonym (Qualified ProperName) [Type]
65+ -- |
66+ -- Forall quantifier
67+ --
68+ | ForAll String Type (Maybe SkolemScope)
69+ -- |
70+ -- A type with a set of type class constraints
71+ --
72+ | ConstrainedType [(Qualified ProperName, [Type])] Type
73+ -- |
74+ -- A skolem constant
75+ --
76+ | Skolem String Int SkolemScope
77+ -- |
78+ -- An empty row
79+ --
80+ | REmpty
81+ -- |
82+ -- A non-empty row
83+ --
84+ | RCons String Type Type
85+ -- |
86+ -- A type with a kind annotation
87+ --
88+ | KindedType Type Kind
89+ --
90+ -- |
91+ -- A placeholder used in pretty printing
92+ --
93+ | PrettyPrintFunction Type Type
94+ -- |
95+ -- A placeholder used in pretty printing
96+ --
97+ | PrettyPrintArray Type
98+ -- |
99+ -- A placeholder used in pretty printing
100+ --
101+ | PrettyPrintObject Type
102+ -- |
103+ -- A placeholder used in pretty printing
104+ --
105+ | PrettyPrintForAll [String] Type deriving (Show, Eq, Data, Typeable)
106+
107+-- |
108+-- Convert a row to a list of pairs of labels and types
109+--
110+rowToList :: Type -> ([(String, Type)], Type)
111+rowToList (RCons name ty row) = let (tys, rest) = rowToList row
112+ in ((name, ty):tys, rest)
113+rowToList r = ([], r)
114+
115+-- |
116+-- Convert a list of labels and types to a row
117+--
118+rowFromList :: ([(String, Type)], Type) -> Type
119+rowFromList ([], r) = r
120+rowFromList ((name, t):ts, r) = RCons name t (rowFromList (ts, r))
121+
122+-- |
123+-- Check whether a type is a monotype
124+--
125+isMonoType :: Type -> Bool
126+isMonoType ForAll{} = False
127+isMonoType _ = True
128+
129+-- |
130+-- Universally quantify a type
131+--
132+mkForAll :: [String] -> Type -> Type
133+mkForAll args ty = foldl (\t arg -> ForAll arg t Nothing) ty args
134+
135+-- |
136+-- Replace a type variable, taking into account variable shadowing
137+--
138+replaceTypeVars :: String -> Type -> Type -> Type
139+replaceTypeVars v r = replaceAllTypeVars [(v, r)]
140+
141+-- |
142+-- Replace named type variables with types
143+--
144+replaceAllTypeVars :: [(String, Type)] -> Type -> Type
145+replaceAllTypeVars = go []
146+ where
147+
148+ go :: [String] -> [(String, Type)] -> Type -> Type
149+ go _ m (TypeVar v) =
150+ case v `lookup` m of
151+ Just r -> r
152+ Nothing -> TypeVar v
153+ go bs m (TypeApp t1 t2) = TypeApp (go bs m t1) (go bs m t2)
154+ go bs m (SaturatedTypeSynonym name' ts) = SaturatedTypeSynonym name' $ map (go bs m) ts
155+ go bs m f@(ForAll v t sco) | v `elem` keys = go bs (filter ((/= v) . fst) m) f
156+ | v `elem` usedVars =
157+ let v' = genName v (keys ++ bs ++ usedVars)
158+ t' = go bs [(v, TypeVar v')] t
159+ in ForAll v' (go (v' : bs) m t') sco
160+ | otherwise = ForAll v (go (v : bs) m t) sco
161+ where
162+ keys = map fst m
163+ usedVars = concatMap (usedTypeVariables . snd) m
164+ go bs m (ConstrainedType cs t) = ConstrainedType (map (second $ map (go bs m)) cs) (go bs m t)
165+ go bs m (RCons name' t r) = RCons name' (go bs m t) (go bs m r)
166+ go bs m (KindedType t k) = KindedType (go bs m t) k
167+ go _ _ ty = ty
168+
169+ genName orig inUse = try 0
170+ where
171+ try :: Integer -> String
172+ try n | (orig ++ show n) `elem` inUse = try (n + 1)
173+ | otherwise = orig ++ show n
174+
175+-- |
176+-- Collect all type variables appearing in a type
177+--
178+usedTypeVariables :: Type -> [String]
179+usedTypeVariables = nub . everythingOnTypes (++) go
180+ where
181+ go (TypeVar v) = [v]
182+ go _ = []
183+
184+-- |
185+-- Collect all free type variables appearing in a type
186+--
187+freeTypeVariables :: Type -> [String]
188+freeTypeVariables = nub . go []
189+ where
190+ go :: [String] -> Type -> [String]
191+ go bound (TypeVar v) | v `notElem` bound = [v]
192+ go bound (TypeApp t1 t2) = go bound t1 ++ go bound t2
193+ go bound (SaturatedTypeSynonym _ ts) = concatMap (go bound) ts
194+ go bound (ForAll v t _) = go (v : bound) t
195+ go bound (ConstrainedType cs t) = concatMap (concatMap (go bound) . snd) cs ++ go bound t
196+ go bound (RCons _ t r) = go bound t ++ go bound r
197+ go bound (KindedType t _) = go bound t
198+ go _ _ = []
199+
200+-- |
201+-- Universally quantify over all type variables appearing free in a type
202+--
203+quantify :: Type -> Type
204+quantify ty = foldr (\arg t -> ForAll arg t Nothing) ty $ freeTypeVariables ty
205+
206+-- |
207+-- Move all universal quantifiers to the front of a type
208+--
209+moveQuantifiersToFront :: Type -> Type
210+moveQuantifiersToFront = go [] []
211+ where
212+ go qs cs (ForAll q ty sco) = go ((q, sco) : qs) cs ty
213+ go qs cs (ConstrainedType cs' ty) = go qs (cs ++ cs') ty
214+ go qs cs ty =
215+ let constrained = case cs of
216+ [] -> ty
217+ cs' -> ConstrainedType cs' ty
218+ in case qs of
219+ [] -> constrained
220+ qs' -> foldl (\ty' (q, sco) -> ForAll q ty' sco) constrained qs'
221+
222+--
223+-- Traversals
224+--
225+
226+everywhereOnTypes :: (Type -> Type) -> Type -> Type
227+everywhereOnTypes f = go
228+ where
229+ go (TypeApp t1 t2) = f (TypeApp (go t1) (go t2))
230+ go (SaturatedTypeSynonym name tys) = f (SaturatedTypeSynonym name (map go tys))
231+ go (ForAll arg ty sco) = f (ForAll arg (go ty) sco)
232+ go (ConstrainedType cs ty) = f (ConstrainedType (map (fmap (map go)) cs) (go ty))
233+ go (RCons name ty rest) = f (RCons name (go ty) (go rest))
234+ go (KindedType ty k) = f (KindedType (go ty) k)
235+ go (PrettyPrintFunction t1 t2) = f (PrettyPrintFunction (go t1) (go t2))
236+ go (PrettyPrintArray t) = f (PrettyPrintArray (go t))
237+ go (PrettyPrintObject t) = f (PrettyPrintObject (go t))
238+ go (PrettyPrintForAll args t) = f (PrettyPrintForAll args (go t))
239+ go other = f other
240+
241+everywhereOnTypesTopDown :: (Type -> Type) -> Type -> Type
242+everywhereOnTypesTopDown f = go . f
243+ where
244+ go (TypeApp t1 t2) = TypeApp (go (f t1)) (go (f t2))
245+ go (SaturatedTypeSynonym name tys) = SaturatedTypeSynonym name (map (go . f) tys)
246+ go (ForAll arg ty sco) = ForAll arg (go (f ty)) sco
247+ go (ConstrainedType cs ty) = ConstrainedType (map (fmap (map (go . f))) cs) (go (f ty))
248+ go (RCons name ty rest) = RCons name (go (f ty)) (go (f rest))
249+ go (KindedType ty k) = KindedType (go (f ty)) k
250+ go (PrettyPrintFunction t1 t2) = PrettyPrintFunction (go (f t1)) (go (f t2))
251+ go (PrettyPrintArray t) = PrettyPrintArray (go (f t))
252+ go (PrettyPrintObject t) = PrettyPrintObject (go (f t))
253+ go (PrettyPrintForAll args t) = PrettyPrintForAll args (go (f t))
254+ go other = f other
255+
256+everywhereOnTypesM :: (Functor m, Applicative m, Monad m) => (Type -> m Type) -> Type -> m Type
257+everywhereOnTypesM f = go
258+ where
259+ go (TypeApp t1 t2) = (TypeApp <$> go t1 <*> go t2) >>= f
260+ go (SaturatedTypeSynonym name tys) = (SaturatedTypeSynonym name <$> mapM go tys) >>= f
261+ go (ForAll arg ty sco) = (ForAll arg <$> go ty <*> pure sco) >>= f
262+ go (ConstrainedType cs ty) = (ConstrainedType <$> mapM (sndM (mapM go)) cs <*> go ty) >>= f
263+ go (RCons name ty rest) = (RCons name <$> go ty <*> go rest) >>= f
264+ go (KindedType ty k) = (KindedType <$> go ty <*> pure k) >>= f
265+ go (PrettyPrintFunction t1 t2) = (PrettyPrintFunction <$> go t1 <*> go t2) >>= f
266+ go (PrettyPrintArray t) = (PrettyPrintArray <$> go t) >>= f
267+ go (PrettyPrintObject t) = (PrettyPrintObject <$> go t) >>= f
268+ go (PrettyPrintForAll args t) = (PrettyPrintForAll args <$> go t) >>= f
269+ go other = f other
270+
271+everywhereOnTypesTopDownM :: (Functor m, Applicative m, Monad m) => (Type -> m Type) -> Type -> m Type
272+everywhereOnTypesTopDownM f = go <=< f
273+ where
274+ go (TypeApp t1 t2) = TypeApp <$> (f t1 >>= go) <*> (f t2 >>= go)
275+ go (SaturatedTypeSynonym name tys) = SaturatedTypeSynonym name <$> mapM (go <=< f) tys
276+ go (ForAll arg ty sco) = ForAll arg <$> (f ty >>= go) <*> pure sco
277+ go (ConstrainedType cs ty) = ConstrainedType <$> mapM (sndM (mapM (go <=< f))) cs <*> (f ty >>= go)
278+ go (RCons name ty rest) = RCons name <$> (f ty >>= go) <*> (f rest >>= go)
279+ go (KindedType ty k) = KindedType <$> (f ty >>= go) <*> pure k
280+ go (PrettyPrintFunction t1 t2) = PrettyPrintFunction <$> (f t1 >>= go) <*> (f t2 >>= go)
281+ go (PrettyPrintArray t) = PrettyPrintArray <$> (f t >>= go)
282+ go (PrettyPrintObject t) = PrettyPrintObject <$> (f t >>= go)
283+ go (PrettyPrintForAll args t) = PrettyPrintForAll args <$> (f t >>= go)
284+ go other = f other
285+
286+everythingOnTypes :: (r -> r -> r) -> (Type -> r) -> Type -> r
287+everythingOnTypes (<>) f = go
288+ where
289+ go t@(TypeApp t1 t2) = f t <> go t1 <> go t2
290+ go t@(SaturatedTypeSynonym _ tys) = foldl (<>) (f t) (map go tys)
291+ go t@(ForAll _ ty _) = f t <> go ty
292+ go t@(ConstrainedType cs ty) = foldl (<>) (f t) (map go $ concatMap snd cs) <> go ty
293+ go t@(RCons _ ty rest) = f t <> go ty <> go rest
294+ go t@(KindedType ty _) = f t <> go ty
295+ go t@(PrettyPrintFunction t1 t2) = f t <> go t1 <> go t2
296+ go t@(PrettyPrintArray t1) = f t <> go t1
297+ go t@(PrettyPrintObject t1) = f t <> go t1
298+ go t@(PrettyPrintForAll _ t1) = f t <> go t1
299+ go other = f other
src/Tests.hsdeleted−141
@@ -1,141 +0,0 @@
1−module Tests (runTests) where
2−
3−import Prelude.Compat
4−import Data.List
5−import Control.Applicative
6−import Control.Monad
7−
8−import System.Process
9−import System.FilePath
10−import System.IO
11−import System.Directory
12−
13−-------------------------------------------------------------------------------
14−testsDir :: IO (FilePath, FilePath)
15−-------------------------------------------------------------------------------
16−testsDir = do
17− baseDir <- getCurrentDirectory
18− return (baseDir </> "purescript-tests", baseDir)
19−
20−-------------------------------------------------------------------------------
21−runTests :: IO ()
22−-------------------------------------------------------------------------------
23−runTests = do
24−
25− (outputDir, baseDir) <- testsDir
26−
27− outputDirExists <- doesDirectoryExist outputDir
28− when outputDirExists $ removeDirectoryRecursive outputDir
29− createDirectory outputDir
30−
31− let srcDir = outputDir </> "src"
32− createDirectory srcDir
33−
34− callProcess "git" ["clone", "--branch", "v0.13.8", "--depth", "1", "https://github.com/purescript/purescript.git"]
35− let passingDir = baseDir </> "purescript" </> "tests" </> "purs" </> "passing"
36− passingTestCases <- sort . filter (".purs" `isSuffixOf`) <$> getDirectoryContents passingDir
37−
38− setCurrentDirectory outputDir
39−
40− fetchPackages
41−
42− let tests = filter (`notElem` skipped) passingTestCases
43−
44− tmp <- getTemporaryDirectory
45− createDirectoryIfMissing False (tmp </> logpath)
46− outputFile <- openFile (tmp </> logpath </> logfile) WriteMode
47− hClose outputFile
48−
49− -- Run the tests
50− --
51− forM_ tests $ \inputFile -> do
52− --
53− -- Compile/build
54− --
55− putStrLn $ "Compiling test " ++ inputFile ++ " ..."
56− setCurrentDirectory outputDir
57− copyFile (passingDir </> inputFile) (srcDir </> inputFile)
58−
59− let testCaseDir = passingDir </> (takeWhile (/='.') inputFile)
60− testCaseDirExists <- doesDirectoryExist testCaseDir
61− when testCaseDirExists $ callProcess "cp" ["-R", testCaseDir, srcDir]
62−
63− callProcess "rm" ["-rf", "output"]
64− callProcess "rm" ["-rf", "Main"]
65− callProcess "spago" ["build"]
66− --
67− -- Run executable file
68− --
69− outputFile <- openFile (tmp </> logpath </> logfile) AppendMode
70− hPutStrLn outputFile ("\n" ++ inputFile ++ ":")
71− proc <- runProcess ("./" </> "Main") [] Nothing Nothing Nothing (Just outputFile) Nothing
72−
73− removeFile (srcDir </> inputFile)
74− when testCaseDirExists $ callProcess "rm" ["-rf", srcDir </> (takeWhile (/='.') inputFile)]
75−
76− -- TODO: support failing test cases
77− --
78− -- let failing = baseDir </> "examples" </> "failing"
79− -- failingTestCases <- sort . filter (".purs" `isSuffixOf`) <$> getDirectoryContents failing
80− --
81−
82− setCurrentDirectory baseDir
83− putStrLn "PureScript tests finished"
84− putStrLn $ "Total tests available: " ++ show (length passingTestCases)
85− putStrLn $ "Tests run: " ++ show (length tests)
86− putStrLn $ "Tests skipped: " ++ show (length skipped)
87−
88−-------------------------------------------------------------------------------
89−packages :: [String]
90−-------------------------------------------------------------------------------
91−packages =
92− [ "arrays"
93− , "assert"
94− , "console"
95− , "control"
96− , "effect"
97− , "foldable-traversable"
98− , "functions"
99− , "generics-rep"
100− , "invariant"
101− , "newtype"
102− , "partial"
103− , "prelude"
104− , "proxy"
105− , "refs"
106− , "st"
107− , "type-equality"
108− , "typelevel-prelude"
109− ]
110−
111−-------------------------------------------------------------------------------
112−fetchPackages :: IO ()
113−-------------------------------------------------------------------------------
114−fetchPackages = do
115− callProcess "spago" ["init"]
116− callCommand "sed '$s/\\(}\\)/, backend = \"psgo\"\\1/' < spago.dhall | dhall format > spago.tmp"
117− callCommand "mv spago.tmp spago.dhall"
118−
119− mapM (callProcess "spago" . (\p -> ["install", p])) packages
120− return ()
121−
122−-------------------------------------------------------------------------------
123−skipped :: [String]
124−-------------------------------------------------------------------------------
125−skipped =
126− [ "2172.purs" -- foreign in Main needed (test manually)
127− , "EffFn.purs" -- foreign in Main needed (test manually)
128− , "FunWithFunDeps.purs" -- foreign in Main needed (test manually)
129− , "NumberLiterals.purs" -- unreliable float string comparison (test manually)
130− , "PolyLabels.purs" -- foreign in Main needed (test manually)
131− , "RowUnion.purs" -- foreign in Main needed (test manually)
132− , "ShadowedModuleName.purs" -- ?
133− , "StringEdgeCases.purs" -- javascript char encoding specific
134− , "StringEscapes.purs" -- Partially javascript-char-encoding-specific (test manually)
135− ]
136−
137−logpath :: FilePath
138−logpath = "purescript-output"
139−
140−logfile :: FilePath
141−logfile = "purescript-tests.out"
stack.nixdeleted−23
@@ -1,23 +0,0 @@
1−#
2−# You may need to manually run `unset STACK_IN_NIX_SHELL`
3−# (doesn't work from a `shellHook`; see: https://github.com/commercialhaskell/stack/issues/5000
4−#
5−#
6−# You may need to set LC_ALL when building, e.g.
7−# LC_ALL=en_US.iso88591 stack --nix build; see e.g. https://github.com/koalaman/shellcheck/issues/324
8−#
9−#
10−{ pkgs ?
11− import (builtins.fetchTarball {
12− name = "nixos-release-19.03";
13− url = https://github.com/nixos/nixpkgs/archive/34c7eb7545d155cc5b6f499b23a7cb1c96ab4d59.tar.gz;
14− sha256 = "11z6ajj108fy2q5g8y4higlcaqncrbjm3dnv17pvif6avagw4mcb";
15− }) {}
16−}:
17−
18−pkgs.haskell.lib.buildStackProject {
19− name = "default-stack-shell";
20− ghc = pkgs.haskell.compiler.ghc865;
21− buildInputs = with pkgs; [git git-lfs gmp ncurses zlib];
22− LANG = "en_US.UTF-8";
23−}
stack.yamldeleted−24
@@ -1,24 +0,0 @@
1−resolver: lts-13.26
2−
3−packages:
4−- .
5−
6−extra-deps:
7−- git: https://github.com/purescript/purescript
8− commit: 9cad73ed8ea7df3011032ddbd2f3de5a0c08629c
9−- happy-1.19.9
10−- language-javascript-0.7.0.0
11−- network-3.0.1.1
12−- these-1.0.1
13−- semialign-1
14−
15−nix:
16− enable: false
17− shell-file: stack.nix
18−
19−flags:
20− aeson-pretty:
21− lib-only: true
22− these:
23− assoc: false
24− quickcheck: false
support/ffi-loader.godeleted−30
@@ -1,30 +0,0 @@
1−package ffi_loader
2−
3−// Load PureScript standard library FFI packages. Comment out the ones you don't need for
4−// faster/smaller builds.
5−
6−import (
7− _ "github.com/purescript-native/go-ffi/purescript-arrays"
8− _ "github.com/purescript-native/go-ffi/purescript-assert"
9− _ "github.com/purescript-native/go-ffi/purescript-console"
10− _ "github.com/purescript-native/go-ffi/purescript-effect"
11− _ "github.com/purescript-native/go-ffi/purescript-enums"
12− _ "github.com/purescript-native/go-ffi/purescript-exceptions"
13− _ "github.com/purescript-native/go-ffi/purescript-foldable-traversable"
14− _ "github.com/purescript-native/go-ffi/purescript-functions"
15− _ "github.com/purescript-native/go-ffi/purescript-globals"
16− _ "github.com/purescript-native/go-ffi/purescript-integers"
17− _ "github.com/purescript-native/go-ffi/purescript-lazy"
18− _ "github.com/purescript-native/go-ffi/purescript-math"
19− _ "github.com/purescript-native/go-ffi/purescript-partial"
20− _ "github.com/purescript-native/go-ffi/purescript-prelude"
21− _ "github.com/purescript-native/go-ffi/purescript-random"
22− _ "github.com/purescript-native/go-ffi/purescript-refs"
23− _ "github.com/purescript-native/go-ffi/purescript-st"
24− _ "github.com/purescript-native/go-ffi/purescript-strings"
25− _ "github.com/purescript-native/go-ffi/purescript-unfoldable"
26−)
27−
28−// Add your own FFI packages here.
29−
30−import ()
support/go.mod.ffi-loaderdeleted−2
@@ -1,2 +0,0 @@
1−module $PROJECT/purescript-native/ffi-loader
2−
support/go.mod.outputdeleted−2
@@ -1,2 +0,0 @@
1−module $PROJECT/purescript-native/output
2−
support/go.mod.workingdeleted−1
@@ -1 +0,0 @@
1−module $PROJECT/example
test/Spec.hsdeleted−2
@@ -1,2 +0,0 @@
1−main :: IO ()
2−main = putStrLn "Test suite not yet implemented"
tests/Main.hsnew file+108
@@ -0,0 +1,108 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Main
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+--
13+-----------------------------------------------------------------------------
14+
15+{-# LANGUAGE DataKinds, DoAndIfThenElse #-}
16+
17+module Main (main) where
18+
19+import qualified Language.PureScript as P
20+
21+import Data.List (isSuffixOf)
22+import Data.Traversable (traverse)
23+import Control.Monad
24+import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)
25+import Control.Applicative
26+import System.Exit
27+import System.Process
28+import System.FilePath (pathSeparator)
29+import System.Directory (getCurrentDirectory, getTemporaryDirectory, getDirectoryContents, findExecutable)
30+import Text.Parsec (ParseError)
31+import qualified System.IO.UTF8 as U
32+
33+readInput :: [FilePath] -> IO [(FilePath, String)]
34+readInput inputFiles = forM inputFiles $ \inputFile -> do
35+ text <- U.readFile inputFile
36+ return (inputFile, text)
37+
38+loadPrelude :: Either String (String, String, P.Environment)
39+loadPrelude =
40+ case P.parseModulesFromFiles id [("", P.prelude)] of
41+ Left parseError -> Left (show parseError)
42+ Right ms -> P.compile (P.defaultCompileOptions { P.optionsAdditional = P.CompileOptions "Tests" [] [] }) (map snd ms) []
43+
44+compile :: P.Options P.Compile -> [FilePath] -> IO (Either String (String, String, P.Environment))
45+compile opts inputFiles = do
46+ modules <- P.parseModulesFromFiles id <$> readInput inputFiles
47+ case modules of
48+ Left parseError ->
49+ return (Left $ show parseError)
50+ Right ms -> return $ P.compile opts (map snd ms) []
51+
52+assert :: FilePath -> P.Options P.Compile -> FilePath -> (Either String (String, String, P.Environment) -> IO (Maybe String)) -> IO ()
53+assert preludeExterns opts inputFile f = do
54+ e <- compile opts [preludeExterns, inputFile]
55+ maybeErr <- f e
56+ case maybeErr of
57+ Just err -> putStrLn err >> exitFailure
58+ Nothing -> return ()
59+
60+assertCompiles :: String -> FilePath -> FilePath -> IO ()
61+assertCompiles preludeJs preludeExterns inputFile = do
62+ putStrLn $ "Assert " ++ inputFile ++ " compiles successfully"
63+ let options = P.defaultCompileOptions
64+ { P.optionsMain = Just "Main"
65+ , P.optionsAdditional = P.CompileOptions "Tests" ["Main"] ["Main"]
66+ }
67+ assert preludeExterns options inputFile $ either (return . Just) $ \(js, _, _) -> do
68+ process <- findNodeProcess
69+ result <- traverse (\node -> readProcessWithExitCode node [] (preludeJs ++ js)) process
70+ case result of
71+ Just (ExitSuccess, out, _) -> putStrLn out >> return Nothing
72+ Just (ExitFailure _, _, err) -> return $ Just err
73+ Nothing -> return $ Just "Couldn't find node.js executable"
74+
75+assertDoesNotCompile :: FilePath -> FilePath -> IO ()
76+assertDoesNotCompile preludeExterns inputFile = do
77+ putStrLn $ "Assert " ++ inputFile ++ " does not compile"
78+ assert preludeExterns (P.defaultCompileOptions { P.optionsAdditional = P.CompileOptions "Tests" [] [] }) inputFile $ \e ->
79+ case e of
80+ Left _ -> return Nothing
81+ Right _ -> return $ Just "Should not have compiled"
82+
83+findNodeProcess :: IO (Maybe String)
84+findNodeProcess = runMaybeT . msum $ map (MaybeT . findExecutable) names
85+ where names = ["nodejs", "node"]
86+
87+main :: IO ()
88+main = do
89+ putStrLn "Compiling Prelude"
90+ case loadPrelude of
91+ Left err -> putStrLn err >> exitFailure
92+ Right (preludeJs, exts, _) -> do
93+ tmp <- getTemporaryDirectory
94+ let preludeExterns = tmp ++ pathSeparator : "prelude.externs"
95+ writeFile preludeExterns exts
96+ putStrLn $ "Wrote " ++ preludeExterns
97+ cd <- getCurrentDirectory
98+ let examples = cd ++ pathSeparator : "examples"
99+ let passing = examples ++ pathSeparator : "passing"
100+ passingTestCases <- getDirectoryContents passing
101+ forM_ passingTestCases $ \inputFile -> when (".purs" `isSuffixOf` inputFile) $
102+ assertCompiles preludeJs preludeExterns (passing ++ pathSeparator : inputFile)
103+ let failing = examples ++ pathSeparator : "failing"
104+ failingTestCases <- getDirectoryContents failing
105+ forM_ failingTestCases $ \inputFile -> when (".purs" `isSuffixOf` inputFile) $
106+ assertDoesNotCompile preludeExterns (failing ++ pathSeparator : inputFile)
107+ exitSuccess
108+